diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index e0ab8791883c..ce391c73e248 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -528,10 +528,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: OutputableBndr name => TyFamInstDecl name -> Located name -tyFamInstDeclLName (TyFamInstSingle { tfid_eqn = - L _ (TyFamInstEqn { tfie_tycon = ln })}) - = ln -tyFamInstDeclLName (TyFamInstBranched { tfid_eqns = +tyFamInstDeclLName (TyFamInstDecl { tfid_eqns = (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ }) -- there may be more than one equation, but grab the name from the first = ln @@ -854,25 +851,12 @@ data TyFamInstEqn name , tfie_rhs :: LHsType name } deriving( Typeable, Data ) -type LTyFamInstSpace name = Located (TyFamInstSpace name) --- | The type space a branched instance lies in -data TyFamInstSpace name - = TyFamInstSpace - { tfis_tycon :: Located name - , tfis_pats :: HsWithBndrs [LHsType name] - } - type LTyFamInstDecl name = Located (TyFamInstDecl name) data TyFamInstDecl name - = TyFamInstSingle - { tfid_eqn :: LTyFamInstEqn name - , tfid_fvs :: NameSet - } - | TyFamInstBranched - { tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns - -- Always non-empty - , tfid_space :: Maybe LTyFamInstSpace -- ^ The (optional) region of the type - -- space this group sits in. + = 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 @@ -943,24 +927,22 @@ tvs are fv(pat_tys), *including* ones that are already in scope Note [Family instance equation groups] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyFamInstBranched contains a list of FamInstEqn's, one for each equation -defined in the branched instance. It is not possible for this list to have 0 -elements -- 'type instance where' without anything else is not allowed. +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 (TyFamInstSingle { tfid_eqn = eqn }) +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = [eqn] }) = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn) -pprTyFamInstDecl top_lvl (TyFamInstBranched { tfid_eqns = eqns, tfid_space = space }) - = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> - ppr_type_space space <+> ptext (sLit "where")) +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns }) + = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext (sLit "where")) 2 (vcat (map ppr eqns)) - where - ppr_type_space Nothing = empty - ppr_type_space (Just s) = ppr s ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = ptext (sLit "instance") diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 0541f214f0a4..34c0bc6901d8 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -676,10 +676,8 @@ {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3 ; return (L loc (TyFamInstD { tfid_inst = tfi })) } } - | 'type' 'instance' maybe_type_space 'where' ty_fam_inst_eqn_list - {% do { L loc tfi <- mkTyFamInstGroup (comb2 $1 $5) - (unLoc $3) (unLoc $5) - ; 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 @@ -697,10 +695,6 @@ -- Type instance groups -maybe_type_space :: { Located (Maybe (LHsType RdrName)) } - : { noLoc Nothing } - | type { LL (Just $1) } - ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] } : '{' ty_fam_inst_eqns '}' { LL (unLoc $2) } | vocurly ty_fam_inst_eqns close { $2 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index f3a0a9113f3e..3695daef5855 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -192,26 +192,15 @@ mkTyFamInst :: SrcSpan -> LTyFamInstEqn RdrName -> P (LTyFamInstDecl RdrName) mkTyFamInst loc eqn - = return (L loc (TyFamInstSingle { tfid_eqn = [eqn] - , tfid_fvs = placeHolderNames })) - -mkTyFamInstGroup :: SrcSpan - -> Maybe (LHsType RdrName) - -> [LTyFamInstEqn RdrName] - -> P TyFamInstDecl RdrName -mkTyFamInstGroup loc mspace eqns - = do { mspace' <- mkTyFamInstSpace mspace - ; return $ L loc (TyFamInstBranched { tfid_eqns = eqns - , tfid_space = mspace' - , tfid_fvs = placeHolderNames }) } - -mkTyFamInstSpace :: Maybe (LHsType RdrName) - -> P (Maybe (LTyFamInstSpace RdrName)) -mkTyFamInstSpace Nothing = return Nothing -mkTyFamInstSpace (Just ty) - = do { (tycon, pats) <- checkTyClHdr ty - ; return (TyFamInstSpace { tfis_tycon = tycon - , tfis_pats = mkHsWithBndrs pats }) } + = 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 } mkFamDecl :: SrcSpan -> FamilyFlavour diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index de42e75f5ee9..cc410388dffd 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -495,29 +495,6 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- strange, but should not matter (and it would be more work -- to remove the context). -rnFamInstLHS :: HsDocContext - -> Maybe (Name, [Name]) - -> Located RdrName - -> [LHsType RdrName] - -> RnM (???) -rnFamInstLHS doc mb_cls tycon pats - = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon - ; let loc = case pats of - [] -> pprPanic "rnFamInstDecl" (ppr tycon) - (L loc _ : []) -> loc - (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) - (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats - - - ; rdr_env <- getLocalRdrEnv - ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names - ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names - -- All the free vars of the family patterns - -- with a sensible binding location - ; (pats', fvs) <- bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ - rnLHsTypes doc pats - rnFamInstDecl :: HsDocContext -> Maybe (Name, [Name]) -> Located RdrName @@ -565,22 +542,11 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload rnTyFamInstDecl :: Maybe (Name, [Name]) -> TyFamInstDecl RdrName -> RnM (TyFamInstDecl Name, FreeVars) -rnTyFamInstDecl mb_cls (TyFamInstSingle { tfid_eqn = eqn }) - = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls) eqn - ; return (TyFamInstSingle { tfid_eqn = eqn' - , tfid_fvs = fvs }, fvs) -rnTyFamInstDecl Nothing (TyFamInstBranched { tfid_eqns = eqns, tfid_space = mspace }) - = do { (eqns', fvs1) <- rnList (rnTyFamInstEqn Nothing) eqns - ; (space', fvs2) <- rn_space mspace - ; let fvs = fvs1 `plusFVs` fvs2 - ; return (TyFamInstBranched { tfid_eqns = eqns' - , tfid_space = space' - , tfid_fvs = fvs }, fvs) } - where rn_space Nothing = (Nothing, emptyFVs) - rn_space (Just (TyFamInstSpace { tfis_tycon = tycon - , tfis_pats = pats })) - = do { tycon' <- lookupFamInstName Nothing tycon - ; let loc +rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqns = eqns, tfid_group = group }) + = do { (eqns', fvs) <- rnList (rnTyFamInstEqn mb_cls) eqns + ; return (TyFamInstDecl { tfid_eqns = eqns' + , tfid_group = group + , tfid_fvs = fvs }, fvs) } rnTyFamInstEqn :: Maybe (Name, [Name]) -> TyFamInstEqn RdrName