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

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
......
This diff is collapsed.
......@@ -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
, 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.
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -65,12 +65,12 @@
(ClosedTypeFamily
(Just
[({ DumpParsedAst.hs:8:3-36 }
(TyFamEqn
({ DumpParsedAst.hs:8:3-8 }
(Unqual
{OccName: Length}))
(HsIB
(PlaceHolder)
(HsIB
(PlaceHolder)
(FamEqn
({ DumpParsedAst.hs:8:3-8 }
(Unqual
{OccName: Length}))
[({ DumpParsedAst.hs:8:10-17 }
(HsParTy
({ DumpParsedAst.hs:8:11-16 }
......@@ -96,64 +96,64 @@
({ DumpParsedAst.hs:8:15-16 }
(Unqual
{OccName: as}))))))]))))]
(PlaceHolder))
(Prefix)
({ DumpParsedAst.hs:8:21-36 }
(HsAppsTy
[({ DumpParsedAst.hs:8:21-24 }
(HsAppPrefix
({ DumpParsedAst.hs:8:21-24 }
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:21-24 }
(Unqual
{OccName: Succ}))))))
,({ DumpParsedAst.hs:8:26-36 }
(HsAppPrefix
({ DumpParsedAst.hs:8:26-36 }
(HsParTy
({ DumpParsedAst.hs:8:27-35 }
(HsAppsTy
[({ DumpParsedAst.hs:8:27-32 }
(HsAppPrefix
({ DumpParsedAst.hs:8:27-32 }
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:27-32 }
(Unqual
{OccName: Length}))))))
,({ DumpParsedAst.hs:8:34-35 }
(HsAppPrefix
({ DumpParsedAst.hs:8:34-35 }
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:34-35 }
(Unqual
{OccName: as}))))))]))))))]))))
(Prefix)
({ DumpParsedAst.hs:8:21-36 }
(HsAppsTy
[({ DumpParsedAst.hs:8:21-24 }
(HsAppPrefix
({ DumpParsedAst.hs:8:21-24 }
(HsTyVar
(NotPromoted)