Commit 384398b3 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Allow optional 'family' and 'instance' keywords in associated type instances

This is to allow

   class C a where
      type family F a
      type instance F a = Bool

   instance C Int where
      type instance F Int = Char

Plus minor improvements relating to Trac #8506
parent 2403fa10
......@@ -629,8 +629,7 @@ ty_decl :: { LTyClDecl RdrName }
| '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 (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4)
; return (L loc (FamDecl decl)) } }
{% mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4) }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs deriving
......@@ -650,8 +649,7 @@ ty_decl :: { LTyClDecl RdrName }
-- data/newtype family
| 'data' 'family' type opt_kind_sig
{% do { L loc decl <- mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4)
; return (L loc (FamDecl decl)) } }
{% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
inst_decl :: { LInstDecl RdrName }
: 'instance' inst_type where_inst
......@@ -663,22 +661,19 @@ inst_decl :: { LInstDecl RdrName }
-- type instance declarations
| 'type' 'instance' ty_fam_inst_eqn
{% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3
; return (L loc (TyFamInstD { tfid_inst = tfi })) } }
{% mkTyFamInst (comb2 $1 $3) $3 }
-- 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
Nothing (reverse (unLoc $4)) (unLoc $5)
; return (L loc (DataFamInstD { dfid_inst = d })) } }
| data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving
{% mkDataFamInst (comb4 $1 $4 $5 $6) (unLoc $1) $3 $4
Nothing (reverse (unLoc $5)) (unLoc $6) }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
| data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
(unLoc $4) (unLoc $5) (unLoc $6)
; return (L loc (DataFamInstD { dfid_inst = d })) } }
{% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4
(unLoc $5) (unLoc $6) (unLoc $7) }
-- Closed type families
......@@ -715,44 +710,46 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
-- data declarations.
--
at_decl_cls :: { LHsDecl RdrName }
-- family declarations
: '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) OpenTypeFamily $2 (unLoc $3)
; return (L loc (TyClD (FamDecl decl))) } }
| 'data' type opt_kind_sig
{% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
; return (L loc (TyClD (FamDecl decl))) } }
-- default type instance
: -- data family declarations, with optional 'family' keyword
'data' opt_family type opt_kind_sig
{% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 (unLoc $4)) }
-- type family declarations, with optional 'family' keyword
-- (can't use opt_instance because you get shift/reduce errors
| 'type' type opt_kind_sig
{% liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 (unLoc $3)) }
| 'type' 'family' type opt_kind_sig
{% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 (unLoc $4)) }
-- default type instances, with optional 'instance' keyword
| 'type' ty_fam_inst_eqn
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { L loc tfi <- mkTyFamInst (comb2 $1 $2) $2
; return (L loc (InstD (TyFamInstD { tfid_inst = tfi }))) } }
{% liftM mkInstD (mkTyFamInst (comb2 $1 $2) $2) }
| 'type' 'instance' ty_fam_inst_eqn
{% liftM mkInstD (mkTyFamInst (comb2 $1 $3) $3) }
opt_family :: { () }
: {- empty -} { () }
| 'family' { () }
-- Associated type instances
--
at_decl_inst :: { LTyFamInstDecl RdrName }
at_decl_inst :: { LInstDecl RdrName }
-- type instance declarations
: 'type' ty_fam_inst_eqn
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% mkTyFamInst (comb2 $1 $2) $2 }
adt_decl_inst :: { LDataFamInstDecl RdrName }
-- data/newtype instance declaration
: data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
| data_or_newtype capi_ctype tycl_hdr constrs deriving
{% mkDataFamInst (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
Nothing (reverse (unLoc $4)) (unLoc $5) }
-- GADT instance declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
deriving
{% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
{% mkDataFamInst (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
(unLoc $4) (unLoc $5) (unLoc $6) }
data_or_newtype :: { Located NewOrData }
......@@ -844,8 +841,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl RdrName)) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (TyFamInstD { tfid_inst = unLoc $1 })))) }
| adt_decl_inst { LL (unitOL (L1 (InstD (DataFamInstD { dfid_inst = unLoc $1 })))) }
decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (unLoc $1)))) }
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
......
......@@ -10,13 +10,14 @@ module RdrHsSyn (
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkFamInstData,
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkTyFamInst,
mkFamDecl,
splitCon, mkInlinePragma,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkTyLit,
mkTyClD, mkInstD,
cvBindGroup,
cvBindsAndSigs,
......@@ -108,6 +109,12 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
mkTyClD :: LTyClDecl n -> LHsDecl n
mkTyClD (L loc d) = L loc (TyClD d)
mkInstD :: LInstDecl n -> LHsDecl n
mkInstD (L loc d) = L loc (InstD d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Located [Located (FunDep RdrName)]
......@@ -118,7 +125,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { let (binds, sigs, ats, at_defs, _, docs) = cvBindsAndSigs (unLoc where_cls)
cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars "class" cls tparams -- Only type vars allowed
; tyvars <- checkTyVars (ptext (sLit "class")) whereDots
cls tparams -- Only type vars allowed
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = reLocate loc cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs,
......@@ -134,26 +142,12 @@ mkTyData :: SrcSpan
-> P (LTyClDecl RdrName)
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars "data" tc tparams
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdLName = reLocate loc tc, tcdTyVars = tyvars,
tcdDataDefn = defn,
tcdFVs = placeHolderNames })) }
mkFamInstData :: SrcSpan
-> NewOrData
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LDataFamInstDecl RdrName)
mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
, dfid_defn = defn, dfid_fvs = placeHolderNames })) }
mkDataDefn :: NewOrData
-> Maybe CType
-> Maybe (LHsContext RdrName)
......@@ -176,7 +170,7 @@ mkTySynonym :: SrcSpan
-> P (LTyClDecl RdrName)
mkTySynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars "type" tc tparams
; tyvars <- checkTyVars (ptext (sLit "type")) equalsDots tc tparams
; return (L loc (SynDecl { tcdLName = reLocate loc tc, tcdTyVars = tyvars
, tcdRhs = rhs, tcdFVs = placeHolderNames })) }
......@@ -189,23 +183,43 @@ mkTyFamInstEqn lhs rhs
, tfie_pats = mkHsWithBndrs tparams
, tfie_rhs = rhs }) }
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LInstDecl RdrName)
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstD (
DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
, dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
mkTyFamInst :: SrcSpan
-> LTyFamInstEqn RdrName
-> P (LTyFamInstDecl RdrName)
-> P (LInstDecl RdrName)
mkTyFamInst loc eqn
= return (L loc (TyFamInstDecl { tfid_eqn = eqn
, tfid_fvs = placeHolderNames }))
= return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn
, tfid_fvs = placeHolderNames })))
mkFamDecl :: SrcSpan
-> FamilyInfo RdrName
-> LHsType RdrName -- LHS
-> Maybe (LHsKind RdrName) -- Optional kind signature
-> P (LFamilyDecl RdrName)
-> P (LTyClDecl RdrName)
mkFamDecl loc info lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars "type family" tc tparams
; return (L loc (FamilyDecl { fdInfo = info, fdLName = reLocate loc tc
, fdTyVars = tyvars, fdKindSig = ksig })) }
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = reLocate loc tc
, fdTyVars = tyvars, fdKindSig = ksig }))) }
where
equals_or_where = case info of
DataFamily -> empty
OpenTypeFamily -> empty
ClosedTypeFamily {} -> whereDots
reLocate :: SrcSpan -> Located a -> Located a
-- For the main binder of a declaration, we make its SrcSpan to
......@@ -491,10 +505,10 @@ we can bring x,y into scope. So:
* For RecCon we do not
\begin{code}
checkTyVars :: String -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature).
checkTyVars what tc tparms = do { tvs <- mapM chk tparms
checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
-- Check that the name space is correct!
......@@ -508,12 +522,11 @@ checkTyVars what tc tparms = do { tvs <- mapM chk tparms
, ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
, vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
, nest 2 (pp_what <+> ppr tc <+> ptext (sLit "a b c")
<+> equals_or_where <+> ptext (sLit "...")) ] ]
<+> equals_or_where) ] ]
pp_what = text what
equals_or_where = case what of
"class" -> ptext (sLit "where")
_ -> equals
whereDots, equalsDots :: SDoc
whereDots = ptext (sLit "where ...")
equalsDots = ptext (sLit "= ...")
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return ()
......
......@@ -5554,7 +5554,7 @@ class Collects ce where
type Elem ce :: *
...
</programlisting>
When doing so, we drop the "<literal>family</literal>" keyword.
When doing so, we (optionally) may drop the "<literal>family</literal>" keyword.
</para>
<para>
The type parameters must all be type variables, of course,
......@@ -5575,7 +5575,7 @@ When doing so, we drop the "<literal>family</literal>" keyword.
<title>Associated instances</title>
<para>
When an associated data or type synonym family instance is declared within a type
class instance, we drop the <literal>instance</literal> keyword in the
class instance, we (optionally) may drop the <literal>instance</literal> keyword in the
family instance:
<programlisting>
instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
......@@ -5629,14 +5629,16 @@ instance GMapKey Flob where
<programlisting>
class IsBoolMap v where
type Key v
type Key v = Int
type instance Key v = Int
lookupKey :: Key v -> v -> Maybe Bool
instance IsBoolMap [(Int, Bool)] where
lookupKey = lookup
</programlisting>
The <literal>instance</literal> keyword is optional.
</para>
<para>
There can also be multiple defaults for a single type, as long as they do not
overlap:
<programlisting>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment