Commit 895a7650 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari
Browse files

Refactor type family instance abstract syntax declarations

This implements @simonpj's suggested refactoring of the abstract syntax
for type/data family instances (from
https://ghc.haskell.org/trac/ghc/ticket/14131#comment:9). This combines
the previously separate `TyFamEqn` and `DataFamInstDecl` types into a
single `FamEqn` datatype. This also factors the `HsImplicitBndrs` out of
`HsTyPats` in favor of putting them just outside of `FamEqn` (as opposed
to before, where all of the implicit binders were embedded inside of
`TyFamEqn`/`DataFamInstDecl`). Finally, along the way I noticed that
`dfid_fvs` and `tfid_fvs` were completely unused, so I removed them.

Aside from some changes in parser test output, there is no change in
behavior.

Requires a Haddock submodule commit from my fork (at
https://github.com/RyanGlScott/haddock/commit/815d2deb9c0222c916becccf84
64b740c26255fd)

Test Plan: ./validate

Reviewers: simonpj, austin, goldfire, bgamari, alanz

Reviewed By: bgamari

Subscribers: mpickering, goldfire, rwbarton, thomie, simonpj

GHC Trac Issues: #14131

Differential Revision: https://phabricator.haskell.org/D3881
parent 5266ab90
......@@ -357,7 +357,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
ClosedTypeFamily Nothing ->
notHandled "abstract closed type family" (ppr decl)
ClosedTypeFamily (Just eqns) ->
do { eqns1 <- mapM repTyFamEqn eqns
do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; result <- repFamilyResultSig resultSig
; inj <- repInjectivityAnn injectivity
......@@ -412,9 +412,9 @@ repAssocTyFamDefaults = mapM rep_deflt
where
-- very like repTyFamEqn, but different in the details
rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
, tfe_pats = bndrs
, tfe_rhs = rhs }))
rep_deflt (L _ (FamEqn { feqn_tycon = tc
, feqn_pats = bndrs
, feqn_rhs = rhs }))
= addTyClTyVarBinds bndrs $ \ _ ->
do { tc1 <- lookupLOcc tc
; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
......@@ -495,10 +495,10 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; eqn1 <- repTyFamEqn eqn
; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
, hsib_vars = var_names }
, tfe_rhs = rhs }))
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_vars = var_names
, hsib_body = FamEqn { feqn_pats = tys
, feqn_rhs = rhs }})
= do { let hs_tvs = HsQTvs { hsq_implicit = var_names
, hsq_explicit = []
, hsq_dependent = emptyNameSet } -- Yuk
......@@ -509,9 +509,11 @@ repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
; repTySynEqn tys2 rhs1 } }
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
, dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
, dfid_defn = defn })
repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_vars = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_pats = tys
, feqn_rhs = defn }})})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_implicit = var_names
, hsq_explicit = []
......
......@@ -300,10 +300,10 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
, dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn
, dfid_fixity = Prefix
, dfid_fvs = placeHolderNames } }}
{ dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
FamEqn { feqn_tycon = tc', feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
......@@ -315,17 +315,16 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
, dd_kindSig = ksig'
, dd_cons = [con'], dd_derivs = derivs' }
; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn
, dfid_fixity = Prefix
, dfid_fvs = placeHolderNames } }}
{ dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
FamEqn { feqn_tycon = tc', feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
; eqn' <- cvtTySynEqn tc' eqn
; L _ eqn' <- cvtTySynEqn tc' eqn
; returnJustL $ InstD $ TyFamInstD
{ tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames } } }
{ tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
cvtDec (OpenTypeFamilyD head)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
......@@ -389,10 +388,11 @@ cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
; rhs' <- cvtType rhs
; returnL $ TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsImplicitBndrs lhs'
, tfe_fixity = Prefix
, tfe_rhs = rhs' } }
; returnL $ mkHsImplicitBndrs
$ FamEqn { feqn_tycon = tc
, feqn_pats = lhs'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
......@@ -430,12 +430,12 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext GhcPs
, Located RdrName
, HsImplicitBndrs GhcPs [LHsType GhcPs])
, HsTyPats GhcPs)
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tys' <- mapM (wrap_apps <=< cvtType) tys
; return (cxt', tc', mkHsImplicitBndrs tys') }
; return (cxt', tc', tys') }
----------------
cvt_tyfam_head :: TypeFamilyHead
......
......@@ -38,7 +38,8 @@ module HsDecls (
InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
FamInstEqn, LFamInstEqn, FamEqn(..),
TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
HsTyPats,
LClsInstDecl, ClsInstDecl(..),
......@@ -592,7 +593,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass)
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(L _ (TyFamEqn { tfe_tycon = ln })) })
(HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
= ln
tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
......@@ -999,7 +1000,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
( text "where"
, case mb_eqns of
Nothing -> text ".."
Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
_ -> (empty, empty)
pprFlavour :: FamilyInfo pass -> SDoc
......@@ -1283,27 +1284,35 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
Note [Type family instance declarations in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The data type TyFamEqn represents one equation of a type family instance.
It is parameterised over its tfe_pats field:
The data type FamEqn represents one equation of a type family instance.
Aside from the pass, it is also parameterised over two fields:
feqn_pats and feqn_rhs.
feqn_pats is either LHsTypes (for ordinary data/type family instances) or
LHsQTyVars (for associated type family default instances). In particular:
* An ordinary type family instance declaration looks like this in source Haskell
type instance T [a] Int = a -> a
(or something similar for a closed family)
It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats
field.
* On the other hand, the *default instance* of an associated type looks like
this in source Haskell
class C a where
type T a b
type T a b = a -> b -- The default instance
It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats
field.
It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in
the feqn_pats field.
feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType
(for type family instances).
-}
----------------- Type synonym family instances -------------
-- | Located Type Family Instance Equation
type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
-- when in a list
......@@ -1313,16 +1322,14 @@ type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
-- | Haskell Type Patterns
type HsTyPats pass = HsImplicitBndrs pass [LHsType pass]
-- ^ Type patterns (with kind and type bndrs)
-- See Note [Family instance declaration binders]
type HsTyPats pass = [LHsType pass]
{- Note [Family instance declaration binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The HsTyPats field is LHS patterns or a type/data family instance.
The hsib_vars of the HsImplicitBndrs are the template variables of the
type patterns, i.e. fv(pat_tys). Note in particular
For ordinary data/type family instances, the feqn_pats field of FamEqn stores
the LHS type (and kind) patterns. These type patterns can of course contain
type (and kind) variables, which are bound in the hsib_vars field of the
HsImplicitBndrs in FamInstEqn. Note in particular
* The hsib_vars *includes* any anonymous wildcards. For example
type instance F a _ = a
......@@ -1344,45 +1351,30 @@ type patterns, i.e. fv(pat_tys). Note in particular
type F (a8,b9) x10 = x10->a8
so that we can compare the type pattern in the 'instance' decl and
in the associated 'type' decl
For associated type family default instances (TyFamDefltEqn), instead of using
type patterns with binders in a surrounding HsImplicitBndrs, we use raw type
variables (LHsQTyVars) in the feqn_pats field of FamEqn.
-}
-- | Type Family Instance Equation
type TyFamInstEqn pass = TyFamEqn pass (HsTyPats pass)
type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
-- | Type Family Default Equation
type TyFamDefltEqn pass = TyFamEqn pass (LHsQTyVars pass)
type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
-- See Note [Type family instance declarations in HsSyn]
-- | Type Family Equation
--
-- One equation in a type family instance declaration
-- See Note [Type family instance declarations in HsSyn]
data TyFamEqn pass pats
= TyFamEqn
{ tfe_tycon :: Located (IdP pass)
, tfe_pats :: pats
, tfe_fixity :: LexicalFixity -- ^ Fixity used in the declaration
, tfe_rhs :: LHsType pass }
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass, Data pats) => Data (TyFamEqn pass pats)
-- | Located Type Family Instance Declaration
type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
-- | Type Family Instance Declaration
data TyFamInstDecl pass
= TyFamInstDecl
{ tfid_eqn :: LTyFamInstEqn pass
, tfid_fvs :: PostRn pass NameSet }
newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
-- 'ApiAnnotation.AnnInstance',
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (TyFamInstDecl pass)
deriving instance DataId pass => Data (TyFamInstDecl pass)
----------------- Data family instances -------------
......@@ -1390,14 +1382,8 @@ deriving instance (DataId pass) => Data (TyFamInstDecl pass)
type LDataFamInstDecl pass = Located (DataFamInstDecl pass)
-- | Data Family Instance Declaration
data DataFamInstDecl pass
= DataFamInstDecl
{ dfid_tycon :: Located (IdP pass)
, dfid_pats :: HsTyPats pass -- LHS
, dfid_fixity :: LexicalFixity -- ^ Fixity used in the declaration
, dfid_defn :: HsDataDefn pass -- RHS
, dfid_fvs :: PostRn pass NameSet }
-- Free vars for dependency analysis
newtype DataFamInstDecl pass
= DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
-- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
......@@ -1406,7 +1392,38 @@ data DataFamInstDecl pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (DataFamInstDecl pass)
deriving instance DataId pass => Data (DataFamInstDecl pass)
----------------- Family instances (common types) -------------
-- | Located Family Instance Equation
type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
-- | Family Instance Equation
type FamInstEqn pass rhs
= HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
-- ^ Here, the @pats@ are type patterns (with kind and type bndrs).
-- See Note [Family instance declaration binders]
-- | Family Equation
--
-- One equation in a type family instance declaration, data family instance
-- declaration, or type family default.
-- See Note [Type family instance declarations in HsSyn]
-- See Note [Family instance declaration binders]
data FamEqn pass pats rhs
= FamEqn
{ feqn_tycon :: Located (IdP pass)
, feqn_pats :: pats
, feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
, feqn_rhs :: rhs
}
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass, Data pats, Data rhs)
=> Data (FamEqn pass pats rhs)
----------------- Class instances -------------
......@@ -1467,19 +1484,19 @@ ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
=> LTyFamInstEqn pass -> SDoc
ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
, tfe_pats = pats
, tfe_fixity = fixity
, tfe_rhs = rhs }))
=> TyFamInstEqn pass -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
=> LTyFamDefltEqn pass -> SDoc
ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
, tfe_pats = tvs
, tfe_fixity = fixity
, tfe_rhs = rhs }))
ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs }))
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
<+> equals <+> ppr rhs
......@@ -1489,17 +1506,19 @@ instance (SourceTextX pass, OutputableBndrId pass)
pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
=> TopLevelFlag -> DataFamInstDecl pass -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
, dfid_pats = pats
, dfid_fixity = fixity
, dfid_defn = defn })
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = defn }}})
= pp_data_defn pp_hdr defn
where
pp_hdr ctxt = ppr_instance_keyword top_lvl
<+> pprFamInstLHS tycon pats fixity ctxt (dd_kindSig defn)
pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc
pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
......@@ -1509,7 +1528,7 @@ pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
-> HsContext pass
-> Maybe (LHsKind pass)
-> SDoc
pprFamInstLHS thing (HsIB { hsib_body = typats }) fixity context mb_kind_sig
pprFamInstLHS thing typats fixity context mb_kind_sig
-- explicit type patterns
= hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
where
......
......@@ -1092,7 +1092,8 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
-- the SrcLoc returned are for the whole declarations, not just the names
hsDataFamInstBinders :: DataFamInstDecl pass
-> ([Located (IdP pass)], [LFieldOcc pass])
hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = defn }}})
= hsDataDefnBinders defn
-- There can't be repeated symbols because only data instances have binders
......
......@@ -1154,21 +1154,23 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
{% asl (unLoc $1) $2 (snd $ unLoc $3)
>> ams $3 (fst $ unLoc $3)
>> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) }
{% let L loc (anns, eqn) = $3 in
asl (unLoc $1) $2 (L loc eqn)
>> ams $3 anns
>> return (sLL $1 $> (L loc eqn : unLoc $1)) }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
| ty_fam_inst_eqn {% ams $1 (fst $ unLoc $1)
>> return (sLL $1 $> [snd $ unLoc $1]) }
| ty_fam_inst_eqn {% let L loc (anns, eqn) = $1 in
ams $1 anns
>> return (sLL $1 $> [L loc eqn]) }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn GhcPs) }
ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
: type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn)) } }
; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
-- Associated type family declarations
--
......
......@@ -159,14 +159,14 @@ mkATDefault :: LTyFamInstDecl GhcPs
--
-- We use the Either monad because this also called
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
| TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity
, tfe_rhs = rhs } <- e
= do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
; return (L loc (TyFamEqn { tfe_tycon = tc
, tfe_pats = tvs
, tfe_fixity = fixity
, tfe_rhs = rhs })) }
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
| FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = rhs } <- e
= do { tvs <- checkTyVars (text "default") equalsDots tc pats
; return (L loc (FamEqn { feqn_tycon = tc
, feqn_pats = tvs
, feqn_fixity = fixity
, feqn_rhs = rhs })) }
mkTyData :: SrcSpan
-> NewOrData
......@@ -221,10 +221,11 @@ mkTyFamInstEqn :: LHsType GhcPs
-> P (TyFamInstEqn GhcPs,[AddAnn])
mkTyFamInstEqn lhs rhs
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; return (TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsImplicitBndrs tparams
, tfe_fixity = fixity
, tfe_rhs = rhs },
; return (mkHsImplicitBndrs
(FamEqn { feqn_tycon = tc
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = rhs }),
ann) }
mkDataFamInst :: SrcSpan
......@@ -239,18 +240,17 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstD (
DataFamInstDecl { dfid_tycon = tc
, dfid_pats = mkHsImplicitBndrs tparams
, dfid_fixity = fixity
, dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
; return (L loc (DataFamInstD (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_tycon = tc
, feqn_pats = tparams
, feqn_fixity = fixity
, feqn_rhs = defn }))))) }
mkTyFamInst :: SrcSpan
-> LTyFamInstEqn GhcPs
-> TyFamInstEqn GhcPs
-> P (LInstDecl GhcPs)
mkTyFamInst loc eqn
= return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn
, tfid_fvs = placeHolderNames })))
= return (L loc (TyFamInstD (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
......
......@@ -688,14 +688,15 @@ getLocalNonValBinders fixity_env
new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_di overload_ok mb_cls ti_decl
= do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
; let (bndrs, flds) = hsDataFamInstBinders ti_decl
new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
HsIB { hsib_body = ti_decl }})
= do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
; let (bndrs, flds) = hsDataFamInstBinders dfid
; sub_names <- mapM newTopSrcBinder bndrs
; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
; let avail = AvailTC (unLoc main_name) sub_names flds'
-- main_name is not bound here!
fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds'
fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
......
......@@ -715,20 +715,22 @@ 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).
rnFamInstDecl :: HsDocContext
-> Maybe (Name, [Name]) -- Nothing => not associated
-- Just (cls,tvs) => associated,
-- and gives class and tyvars of the
-- parent instance delc
-> Located RdrName
-> HsTyPats GhcPs
-> rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (Located Name, HsTyPats GhcRn, rhs', FreeVars)
rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
rnFamInstEqn :: HsDocContext
-> Maybe (Name, [Name]) -- Nothing => not associated
-- Just (cls,tvs) => associated,
-- and gives class and tyvars of the
-- parent instance delc
-> FamInstEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamInstEqn GhcRn rhs', FreeVars)
rnFamInstEqn doc mb_cls (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = payload }})
rnPayload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
[] -> pprPanic "rnFamInstEqn" (ppr tycon)
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
......@@ -786,67 +788,54 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
-- Note [Wildcards in family instances]
all_fvs = fvs `addOneFV` unLoc tycon'
; return (tycon',
HsIB { hsib_body = pats'
, hsib_vars = all_ibs
, hsib_closed = True },
payload',
; return (HsIB { hsib_vars = all_ibs
, hsib_closed = True
, hsib_body
= FamEqn { feqn_tycon = tycon'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = payload' } },
all_fvs) }
-- type instance => use, hence addOneFV
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
= do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
; return (TyFamInstDecl { tfid_eqn = L loc eqn'
, tfid_fvs = fvs }, fvs) }
; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = pats
, tfe_fixity = fixity
, tfe_rhs = rhs })
= do { (tycon', pats', rhs', fvs) <-
rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
; return (TyFamEqn { tfe_tycon = tycon'
, tfe_pats = pats'
, tfe_fixity = fixity
, tfe_rhs = rhs' }, fvs) }
rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon }})
= rnFamInstEqn (TySynCtx tycon) mb_cls eqn rnTySyn
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn GhcPs
-> RnM (TyFamDefltEqn GhcRn, FreeVars)
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon