diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2017-08-29 12:38:54 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-08-29 12:39:18 -0400 |
commit | 895a7650a038131f3043f882c558c627abe9a61e (patch) | |
tree | 69a1948f4303d5801ac21884c68a61556e285268 /compiler | |
parent | 5266ab9059dffa741b172636f50f1fbfd491dbb4 (diff) | |
download | haskell-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.hs | 24 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.hs | 34 | ||||
-rw-r--r-- | compiler/hsSyn/HsDecls.hs | 145 | ||||
-rw-r--r-- | compiler/hsSyn/HsUtils.hs | 3 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 16 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 40 | ||||
-rw-r--r-- | compiler/rename/RnNames.hs | 9 | ||||
-rw-r--r-- | compiler/rename/RnSource.hs | 89 | ||||
-rw-r--r-- | compiler/typecheck/TcEnv.hs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 30 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 74 |
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 |