summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2017-08-29 12:38:54 -0400
committerBen Gamari <ben@smart-cactus.org>2017-08-29 12:39:18 -0400
commit895a7650a038131f3043f882c558c627abe9a61e (patch)
tree69a1948f4303d5801ac21884c68a61556e285268 /compiler
parent5266ab9059dffa741b172636f50f1fbfd491dbb4 (diff)
downloadhaskell-895a7650a038131f3043f882c558c627abe9a61e.tar.gz
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
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsMeta.hs24
-rw-r--r--compiler/hsSyn/Convert.hs34
-rw-r--r--compiler/hsSyn/HsDecls.hs145
-rw-r--r--compiler/hsSyn/HsUtils.hs3
-rw-r--r--compiler/parser/Parser.y16
-rw-r--r--compiler/parser/RdrHsSyn.hs40
-rw-r--r--compiler/rename/RnNames.hs9
-rw-r--r--compiler/rename/RnSource.hs89
-rw-r--r--compiler/typecheck/TcEnv.hs3
-rw-r--r--compiler/typecheck/TcInstDcls.hs30
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs74
11 files changed, 249 insertions, 218 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b78e366a4a..5e630e56ac 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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 = []
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index de36a85937..a9df2b2554 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 5a6d3dde27..cb67be8ed7 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 374fbe926c..a72e3c8469 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 672b6f74ab..e3deb31bd5 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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
--
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index ecfae760a8..41d8a4a339 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -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
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 6197bc7480..84e62f0113 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -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
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 4ac670c99a..cb9c960dce 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -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
- , tfe_pats = tyvars
- , tfe_fixity = fixity
- , tfe_rhs = rhs })
+rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
+ , feqn_pats = tyvars
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })
= bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
- ; return (TyFamEqn { tfe_tycon = tycon'
- , tfe_pats = tyvars'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' }, fvs) }
+ ; return (FamEqn { feqn_tycon = tycon'
+ , feqn_pats = tyvars'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' }, fvs) }
where
ctx = TyFamilyCtx tycon
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
-rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
- , dfid_pats = pats
- , dfid_fixity = fixity
- , dfid_defn = defn })
- = do { (tycon', pats', defn', fvs) <-
- rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
- ; return (DataFamInstDecl { dfid_tycon = tycon'
- , dfid_pats = pats'
- , dfid_fixity = fixity
- , dfid_defn = defn'
- , dfid_fvs = fvs }, fvs) }
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
+ FamEqn { feqn_tycon = tycon }})})
+ = do { (eqn', fvs) <-
+ rnFamInstEqn (TyDataCtx tycon) mb_cls eqn rnDataDefn
+ ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
-- Renaming of the associated types in instances.
@@ -889,7 +878,7 @@ is the same as
This is implemented as follows: during renaming anonymous wild cards
'_' are given freshly generated names. These names are collected after
-renaming (rnFamInstDecl) and used to make new type variables during
+renaming (rnFamInstEqn) and used to make new type variables during
type checking (tc_fam_ty_pats). One should not confuse these wild
cards with the ones from partial type signatures. The latter generate
fresh meta-variables whereas the former generate fresh skolems.
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 12f8a1df4f..4a271345fb 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -592,7 +592,8 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
- get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
+ get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
= map unLoc $ concatMap (getConNames . unLoc) cons
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index a3da31dffd..2f3d358361 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -487,7 +487,10 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
-- from their defaults (if available)
; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
`unionNameSet`
- mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
+ mkNameSet (map (unLoc . feqn_tycon
+ . hsib_body
+ . dfid_eqn
+ . unLoc) adts)
; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
(classATItems clas)
@@ -600,7 +603,7 @@ tcTyFamInstDecl :: Maybe ClsInstInfo
tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
= setSrcSpan loc $
tcAddTyFamInstCtxt decl $
- do { let fam_lname = tfe_tycon (unLoc eqn)
+ do { let fam_lname = feqn_tycon (hsib_body eqn)
; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
-- (0) Check it's an open type family
@@ -609,7 +612,8 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
-- (1) do the work of verifying the synonym group
- ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo eqn
+ ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo
+ (L (getLoc fam_lname) eqn)
-- (2) check for validity
; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
@@ -623,13 +627,17 @@ tcDataFamInstDecl :: Maybe ClsInstInfo
-> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
-- "newtype instance" and "data instance"
tcDataFamInstDecl mb_clsinfo
- (L loc decl@(DataFamInstDecl
- { dfid_pats = pats
- , dfid_tycon = fam_tc_name
- , dfid_fixity = fixity
- , dfid_defn = HsDataDefn { dd_ND = new_or_data, dd_cType = cType
- , dd_ctxt = ctxt, dd_cons = cons
- , dd_kindSig = m_ksig, dd_derivs = derivs } }))
+ (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_vars = tv_names
+ , hsib_body =
+ FamEqn { feqn_pats = pats
+ , feqn_tycon = fam_tc_name
+ , feqn_fixity = fixity
+ , feqn_rhs = HsDataDefn { dd_ND = new_or_data
+ , dd_cType = cType
+ , dd_ctxt = ctxt
+ , dd_cons = cons
+ , dd_kindSig = m_ksig
+ , dd_derivs = derivs } }}}))
= setSrcSpan loc $
tcAddDataFamInstCtxt decl $
do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
@@ -640,7 +648,7 @@ tcDataFamInstDecl mb_clsinfo
-- Kind check type patterns
; let mb_kind_env = thdOf3 <$> mb_clsinfo
- ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
+ ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo tv_names pats
(kcDataDefn mb_kind_env decl) $
\tvs pats res_kind ->
do { stupid_theta <- solveEqualities $ tcHsContext ctxt
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index a152942020..f0afdb6499 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1060,7 +1060,7 @@ tcClassATs class_name cls ats at_defs
; mapM tc_at ats }
where
at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
- at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn)
+ at_def_tycon (L _ eqn) = unLoc (feqn_tycon eqn)
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name (L _ decl) = unLoc (fdLName decl)
@@ -1088,11 +1088,12 @@ tcDefaultAssocDecl _ []
tcDefaultAssocDecl _ (d1:_:_)
= failWithTc (text "More than one default declaration for"
- <+> ppr (tfe_tycon (unLoc d1)))
+ <+> ppr (feqn_tycon (unLoc d1)))
-tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = lname@(L _ tc_name)
- , tfe_pats = hs_tvs, tfe_fixity = fixity
- , tfe_rhs = rhs })]
+tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = lname@(L _ tc_name)
+ , feqn_pats = hs_tvs
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })]
| HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs
= -- See Note [Type-checking default assoc decls]
setSrcSpan loc $
@@ -1110,10 +1111,9 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = lname@(L _ tc_name)
(wrongNumberOfParmsErr fam_arity)
-- Typecheck RHS
- ; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars
- , hsib_body = map hsLTyVarBndrToType exp_vars
- , hsib_closed = False } -- this field is ignored, anyway
- pp_lhs = pprFamInstLHS lname pats fixity [] Nothing
+ ; let all_vars = imp_vars ++ map hsLTyVarName exp_vars
+ pats = map hsLTyVarBndrToType exp_vars
+ pp_lhs = pprFamInstLHS lname pats fixity [] Nothing
-- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get
-- the LHsQTyVars used for declaring a tycon, but the names here
@@ -1124,7 +1124,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = lname@(L _ tc_name)
-- type default LHS can mention *different* type variables than the
-- enclosing class. So it's treated more as a freestanding beast.
; (pats', rhs_ty)
- <- tcFamTyPats shape Nothing pats
+ <- tcFamTyPats shape Nothing all_vars pats
(kcTyFamEqnRhs Nothing pp_lhs rhs) $
\tvs pats rhs_kind ->
do { rhs_ty <- solveEqualities $
@@ -1168,16 +1168,17 @@ proper tcMatchTys here.) -}
-------------------------
kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name })
- (L loc (TyFamEqn { tfe_tycon = lname@(L _ eqn_tc_name)
- , tfe_pats = pats
- , tfe_fixity = fixity
- , tfe_rhs = hs_ty }))
+ (L loc (HsIB { hsib_vars = tv_names
+ , hsib_body = FamEqn { feqn_tycon = lname@(L _ eqn_tc_name)
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = hs_ty }}))
= setSrcSpan loc $
do { checkTc (fam_tc_name == eqn_tc_name)
(wrongTyFamName fam_tc_name eqn_tc_name)
; discardResult $
tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
- pats (kcTyFamEqnRhs Nothing pp_lhs hs_ty) }
+ tv_names pats (kcTyFamEqnRhs Nothing pp_lhs hs_ty) }
where
pp_lhs = pprFamInstLHS lname pats fixity [] Nothing
@@ -1207,13 +1208,14 @@ tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
-- Needs to be here, not in TcInstDcls, because closed families
-- (typechecked here) have TyFamInstEqns
tcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name }) mb_clsinfo
- (L loc (TyFamEqn { tfe_tycon = lname@(L _ eqn_tc_name)
- , tfe_pats = pats
- , tfe_fixity = fixity
- , tfe_rhs = hs_ty }))
+ (L loc (HsIB { hsib_vars = tv_names
+ , hsib_body = FamEqn { feqn_tycon = lname@(L _ eqn_tc_name)
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = hs_ty }}))
= ASSERT( fam_tc_name == eqn_tc_name )
setSrcSpan loc $
- tcFamTyPats fam_tc_shape mb_clsinfo pats
+ tcFamTyPats fam_tc_shape mb_clsinfo tv_names pats
(kcTyFamEqnRhs mb_clsinfo pp_lhs hs_ty) $
\tvs pats res_kind ->
do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
@@ -1240,11 +1242,13 @@ kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars
-- Used for 'data instance' only
-- Ordinary 'data' is handled by kcTyClDec
kcDataDefn mb_kind_env
- (DataFamInstDecl
- { dfid_tycon = fam_name
- , dfid_pats = pats
- , dfid_fixity = fixity
- , dfid_defn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind } })
+ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+ FamEqn { feqn_tycon = fam_name
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = HsDataDefn { dd_ctxt = ctxt
+ , dd_cons = cons
+ , dd_kindSig = mb_kind } }}})
res_k
= do { _ <- tcHsContext ctxt
; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons
@@ -1373,7 +1377,8 @@ famTyConShape fam_tc
tc_fam_ty_pats :: FamTyConShape
-> Maybe ClsInstInfo
- -> HsTyPats GhcRn -- Patterns
+ -> [Name] -- Bound kind/type variable names
+ -> HsTyPats GhcRn -- Type patterns
-> (TcKind -> TcM r) -- Kind checker for RHS
-> TcM ([Type], r) -- Returns the type-checked patterns
-- Check the type patterns of a type or data family instance
@@ -1390,7 +1395,7 @@ tc_fam_ty_pats :: FamTyConShape
tc_fam_ty_pats (FamTyConShape { fs_name = name, fs_arity = arity
, fs_flavor = flav, fs_binders = binders
, fs_res_kind = res_kind })
- mb_clsinfo (HsIB { hsib_body = arg_pats, hsib_vars = tv_names })
+ mb_clsinfo tv_names arg_pats
kind_checker
= do { -- First, check the arity.
-- If we wait until validity checking, we'll get kind
@@ -1428,7 +1433,8 @@ tc_fam_ty_pats (FamTyConShape { fs_name = name, fs_arity = arity
-- See Note [tc_fam_ty_pats vs tcFamTyPats]
tcFamTyPats :: FamTyConShape
-> Maybe ClsInstInfo
- -> HsTyPats GhcRn -- patterns
+ -> [Name] -- Implicitly bound kind/type variable names
+ -> HsTyPats GhcRn -- Type patterns
-> (TcKind -> TcM ([TcType], TcKind))
-- kind-checker for RHS
-- See Note [Instantiating a family tycon]
@@ -1437,11 +1443,12 @@ tcFamTyPats :: FamTyConShape
-> TcKind
-> TcM a) -- NB: You can use solveEqualities here.
-> TcM a
-tcFamTyPats fam_shape@(FamTyConShape { fs_name = name }) mb_clsinfo pats
- kind_checker thing_inside
+tcFamTyPats fam_shape@(FamTyConShape { fs_name = name }) mb_clsinfo
+ tv_names arg_pats kind_checker thing_inside
= do { (typats, (more_typats, res_kind))
<- solveEqualities $ -- See Note [Constraints in patterns]
- tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker
+ tc_fam_ty_pats fam_shape mb_clsinfo
+ tv_names arg_pats kind_checker
{- TODO (RAE): This should be cleverer. Consider this:
@@ -3062,9 +3069,10 @@ tcAddTyFamInstCtxt decl
= tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
-tcMkDataFamInstCtxt decl
+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
+ HsIB { hsib_body = eqn }})
= tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
- (unLoc (dfid_tycon decl))
+ (unLoc (feqn_tycon eqn))
tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt decl