Commit c079de3c authored by bollmann's avatar bollmann Committed by Ben Gamari

Add TH support for pattern synonyms (fixes #8761)

This commit adds Template Haskell support for pattern synonyms as
requested by trac ticket #8761.

Test Plan: ./validate

Reviewers: thomie, jstolarek, osa1, RyanGlScott, mpickering, austin,
goldfire, bgamari

Reviewed By: goldfire, bgamari

Subscribers: rdragon

Differential Revision: https://phabricator.haskell.org/D1940

GHC Trac Issues: #8761
parent e2172873
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, TypeFamilies #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
...@@ -119,8 +119,9 @@ repTopDs group@(HsGroup { hs_valds = valds ...@@ -119,8 +119,9 @@ repTopDs group@(HsGroup { hs_valds = valds
, hs_ruleds = ruleds , hs_ruleds = ruleds
, hs_vects = vects , hs_vects = vects
, hs_docs = docs }) , hs_docs = docs })
= do { let { tv_bndrs = hsSigTvBinders valds = do { let { bndrs = hsSigTvBinders valds
; bndrs = tv_bndrs ++ hsGroupBinders group ++ hsGroupBinders group
++ hsPatSynSelectors valds
; instds = tyclds >>= group_instds } ; ; instds = tyclds >>= group_instds } ;
ss <- mkGenSyms bndrs ; ss <- mkGenSyms bndrs ;
...@@ -197,7 +198,6 @@ hsSigTvBinders binds ...@@ -197,7 +198,6 @@ hsSigTvBinders binds
ValBindsIn _ sigs -> sigs ValBindsIn _ sigs -> sigs
ValBindsOut _ sigs -> sigs ValBindsOut _ sigs -> sigs
{- Notes {- Notes
Note [Scoped type variables in bindings] Note [Scoped type variables in bindings]
...@@ -700,7 +700,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; ...@@ -700,7 +700,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty rep_sig (L loc (PatSynSig nm ty)) = (:[]) <$> rep_patsyn_ty_sig loc ty nm
rep_sig (L loc (ClassOpSig is_deflt nms ty)) rep_sig (L loc (ClassOpSig is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
...@@ -708,7 +708,7 @@ rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) ...@@ -708,7 +708,7 @@ rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm tys ispec)) rep_sig (L loc (SpecSig nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys = concatMapM (\t -> rep_specialise nm t ispec loc) tys
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
...@@ -720,6 +720,16 @@ rep_ty_sig mk_sig loc sig_ty nm ...@@ -720,6 +720,16 @@ rep_ty_sig mk_sig loc sig_ty nm
; sig <- repProto mk_sig nm1 ty1 ; sig <- repProto mk_sig nm1 ty1
; return (loc, sig) } ; return (loc, sig) }
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
-- represents a pattern synonym type signature; see NOTE [Pattern
-- synonym signatures and Template Haskell]
rep_patsyn_ty_sig loc sig_ty nm
= do { nm1 <- lookupLOcc nm
; ty1 <- repHsPatSynSigType sig_ty
; sig <- repProto patSynSigDName nm1 ty1
; return (loc, sig) }
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ) -> DsM (SrcSpan, Core TH.DecQ)
-- We must special-case the top-level explicit for-all of a TypeSig -- We must special-case the top-level explicit for-all of a TypeSig
...@@ -889,17 +899,32 @@ repHsSigType (HsIB { hsib_vars = vars ...@@ -889,17 +899,32 @@ repHsSigType (HsIB { hsib_vars = vars
then return th_ty then return th_ty
else repTForall th_tvs th_ctxt th_ty } else repTForall th_tvs th_ctxt th_ty }
repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
, hsib_body = body })
= addTyVarBinds (newTvs (impls ++ univs)) $ \th_univs ->
addTyVarBinds (newTvs exis) $ \th_exis ->
do { th_reqs <- repLContext reqs
; th_provs <- repLContext provs
; th_ty <- repLTy ty
; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
where
impls = map (noLoc . UserTyVar . noLoc) implicit_tvs
newTvs tvs = HsQTvs
{ hsq_implicit = []
, hsq_explicit = tvs
, hsq_dependent = emptyNameSet }
(univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 }) repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 })
= repHsSigType (ib_ty { hsib_body = hswc_body sig1 }) = repHsSigType (ib_ty { hsib_body = hswc_body sig1 })
-- yield the representation of a list of types -- yield the representation of a list of types
--
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys repLTys tys = mapM repLTy tys
-- represent a type -- represent a type
--
repLTy :: LHsType Name -> DsM (Core TH.TypeQ) repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty repLTy (L _ ty) = repTy ty
...@@ -1073,11 +1098,11 @@ repE :: HsExpr Name -> DsM (Core TH.ExpQ) ...@@ -1073,11 +1098,11 @@ repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar (L _ x)) = repE (HsVar (L _ x)) =
do { mb_val <- dsLookupMetaEnv x do { mb_val <- dsLookupMetaEnv x
; case mb_val of ; case mb_val of
Nothing -> do { str <- globalVar x Nothing -> do { str <- globalVar x
; repVarOrCon x str } ; repVarOrCon x str }
Just (DsBound y) -> repVarOrCon x (coreVar y) Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } } ; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e) repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
...@@ -1415,7 +1440,87 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ...@@ -1415,7 +1440,87 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig" rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec) rep_bind (L loc (PatSynBind (PSB { psb_id = syn
, psb_fvs = _fvs
, psb_args = args
, psb_def = pat
, psb_dir = dir })))
= do { syn' <- lookupLBinder syn
; dir' <- repPatSynDir dir
; ss <- mkGenArgSyms args
; patSynD' <- addBinds ss (
do { args' <- repPatSynArgs args
; pat' <- repLP pat
; repPatSynD syn' args' dir' pat' })
; patSynD'' <- wrapGenArgSyms args ss patSynD'
; return (loc, patSynD'') }
where
mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
-- for Record Pattern Synonyms we want to conflate the selector
-- and the pattern-only names in order to provide a nicer TH
-- API. Whereas inside GHC, record pattern synonym selectors and
-- their pattern-only bound right hand sides have different names,
-- we want to treat them the same in TH. This is the reason why we
-- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.
mkGenArgSyms (PrefixPatSyn args) = mkGenSyms (map unLoc args)
mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecordPatSyn fields)
= do { let pats = map (unLoc . recordPatSynPatVar) fields
sels = map (unLoc . recordPatSynSelectorId) fields
; ss <- mkGenSyms sels
; return $ replaceNames (zip sels pats) ss }
replaceNames selsPats genSyms
= [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
, sel == sel' ]
wrapGenArgSyms :: HsPatSynDetails (Located Name)
-> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
wrapGenArgSyms (RecordPatSyn _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ
-> Core TH.PatSynDirQ
-> Core TH.PatQ
-> DsM (Core TH.DecQ)
repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
= rep2 patSynDName [syn, args, dir, pat]
repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
repPatSynArgs (PrefixPatSyn args)
= do { args' <- repList nameTyConName lookupLOcc args
; repPrefixPatSynArgs args' }
repPatSynArgs (InfixPatSyn arg1 arg2)
= do { arg1' <- lookupLOcc arg1
; arg2' <- lookupLOcc arg2
; repInfixPatSynArgs arg1' arg2' }
repPatSynArgs (RecordPatSyn fields)
= do { sels' <- repList nameTyConName lookupLOcc sels
; repRecordPatSynArgs sels' }
where sels = map recordPatSynSelectorId fields
repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
repRecordPatSynArgs :: Core [TH.Name]
-> DsM (Core TH.PatSynArgsQ)
repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ)
repPatSynDir Unidirectional = rep2 unidirPatSynName []
repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
= do { clauses' <- mapM repClauseTup clauses
; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Since everything in a Bind is mutually recursive we need rename all -- Since everything in a Bind is mutually recursive we need rename all
-- all the variables simultaneously. For example: -- all the variables simultaneously. For example:
......
...@@ -350,6 +350,33 @@ cvtDec (TH.DefaultSigD nm typ) ...@@ -350,6 +350,33 @@ cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; ty' <- cvtType typ ; ty' <- cvtType typ
; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
; args' <- cvtArgs args
; dir' <- cvtDir dir
; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind $
PSB nm' placeHolderType args' pat' dir' }
where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
cvtArgs (TH.RecordPatSyn sels)
= do { sels' <- mapM vNameL sels
; vars' <- mapM (vNameL . mkNameS . nameBase) sels
; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
cvtDir Unidir = return Unidirectional
cvtDir ImplBidir = return ImplicitBidirectional
cvtDir (ExplBidir cls) =
do { ms <- mapM cvtClause cls
; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
; returnJustL $ Hs.SigD $ PatSynSig nm' (mkLHsSigType ty') }
---------------- ----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs) cvtTySynEqn tc (TySynEqn lhs rhs)
...@@ -725,9 +752,9 @@ cvtl e = wrapL (cvt e) ...@@ -725,9 +752,9 @@ cvtl e = wrapL (cvt e)
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
| otherwise = do { l' <- cvtLit l; return $ HsLit l' } | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp (mkLHsPar x') y' } ; return $ HsApp (mkLHsPar x') y' }
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp x' y' } ; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) } ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
...@@ -1276,6 +1303,27 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) ...@@ -1276,6 +1303,27 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
; annRHS' <- mapM tNameL annRHS ; annRHS' <- mapM tNameL annRHS
; returnL (Hs.InjectivityAnn annLHS' annRHS') } ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName)
-- pattern synonym types are of peculiar shapes, which is why we treat
-- them separately from regular types; see NOTE [Pattern synonym
-- signatures and Template Haskell]
cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
| null exis, null provs = cvtType (ForallT univs reqs ty)
| null univs, null reqs = do { l <- getL
; ty' <- cvtType (ForallT exis provs ty)
; return $ L l (HsQualTy { hst_ctxt = L l []
, hst_body = ty' }) }
| null reqs = do { l <- getL
; univs' <- hsQTvExplicit <$> cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
; let forTy = HsForAllTy { hst_bndrs = univs'
, hst_body = L l cxtTy }
cxtTy = HsQualTy { hst_ctxt = L l []
, hst_body = ty' }
; return $ L l forTy }
| otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
cvtPatSynSigTy ty = cvtType ty
----------------------------------------------------------- -----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir) cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir)
...@@ -1474,3 +1522,59 @@ the way System Names are printed. ...@@ -1474,3 +1522,59 @@ the way System Names are printed.
There's a small complication of course; see Note [Looking up Exact There's a small complication of course; see Note [Looking up Exact
RdrNames] in RnEnv. RdrNames] in RnEnv.
-} -}
{-
Note [Pattern synonym type signatures and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general, the type signature of a pattern synonym
pattern P x1 x2 .. xn = <some-pattern>
is of the form
forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
with the following parts:
1) the (possibly empty lists of) universally quantified type
variables `univs` and required constraints `reqs` on them.
2) the (possibly empty lists of) existentially quantified type
variables `exis` and the provided constraints `provs` on them.
3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
x2, .., xn, respectively
4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
Due to the two forall quantifiers and constraint contexts (either of
which might be empty), pattern synonym type signatures are treated
specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
`typecheck/TcSplice.hs`:
(a) When desugaring a pattern synonym from HsSyn to TH.Dec in
`deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
ForallT univs reqs (ForallT exis provs ty)
(where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
(b) When converting pattern synonyms from TH.Dec to HsSyn in
`hsSyn/Convert.hs`, we convert their TH type signatures back to an
appropriate Haskell pattern synonym type of the form
forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
where initial empty `univs` type variables or an empty `reqs`
constraint context are represented *explicitly* as `() =>`.
(c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
return its *full* type, i.e.:
ForallT univs reqs (ForallT exis provs ty)
(where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
The key point is to always represent a pattern synonym's *full* type
in cases (a) and (c) to make it clear which of the two forall
quantifiers and/or constraint contexts are specified, and which are
not. See GHC's users guide on pattern synonyms for more information
about pattern synonym type signatures.
-}
...@@ -984,22 +984,17 @@ splitHsAppTys f as = (f,as) ...@@ -984,22 +984,17 @@ splitHsAppTys f as = (f,as)
-------------------------------- --------------------------------
splitLHsPatSynTy :: LHsType name splitLHsPatSynTy :: LHsType name
-> ( [LHsTyVarBndr name] -> ( [LHsTyVarBndr name] -- universals
, LHsContext name -- Required , LHsContext name -- required constraints
, LHsContext name -- Provided , [LHsTyVarBndr name] -- existentials
, LHsType name) -- Body , LHsContext name -- provided constraints
splitLHsPatSynTy ty , LHsType name) -- body type
| L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1 splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
, L _ (HsQualTy { hst_ctxt = prov, hst_body = ty3 }) <- ty2
= (tvs, req, prov, ty3)
| L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1
= (tvs, req, noLoc [], ty2)
| otherwise
= (tvs, noLoc [], noLoc [], ty1)
where where
(tvs, ty1) = splitLHsForAllTy ty (univs, ty1) = splitLHsForAllTy ty
(reqs, ty2) = splitLHsQualTy ty1
(exis, ty3) = splitLHsForAllTy ty2
(provs, ty4) = splitLHsQualTy ty3
splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name) splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name)
splitLHsSigmaTy ty splitLHsSigmaTy ty
......
...@@ -78,7 +78,7 @@ module HsUtils( ...@@ -78,7 +78,7 @@ module HsUtils(
collectLStmtsBinders, collectStmtsBinders, collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders, collectLStmtBinders, collectStmtBinders,
hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders, hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
hsDataDefnBinders, hsDataDefnBinders,
...@@ -784,8 +784,9 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ ...@@ -784,8 +784,9 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
-- The only time we collect binders from a typechecked -- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn -- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc = collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
if omitPatSyn then acc else ps : acc | omitPatSyn = acc
| otherwise = ps : acc
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds -- Used exclusively for the bindings of an instance decl which are all FunBinds
...@@ -935,26 +936,19 @@ hsForeignDeclsBinders foreign_decls ...@@ -935,26 +936,19 @@ hsForeignDeclsBinders foreign_decls
| L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
------------------- -------------------
hsPatSynBinders :: HsValBinds RdrName hsPatSynSelectors :: HsValBinds id -> [id]
-> ([Located RdrName], [Located RdrName]) -- Collects record pattern-synonym selectors only; the pattern synonym
-- Collect pattern-synonym binders only, not Ids -- names are collected by collectHsValBinders.
-- See Note [SrcSpan for binders] hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds hsPatSynSelectors (ValBindsOut binds _)
hsPatSynBinders _ = panic "hsPatSynBinders" = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id]) addPatSynSelector:: LHsBind id -> [id] -> [id]
-> ([Located id], [Located id]) -- (selectors, other) addPatSynSelector bind sels
-- See Note [SrcSpan for binders] | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
addPatSynBndr bind (sels, pss) = map (unLoc . recordPatSynSelectorId) as ++ sels
| L bind_loc (PatSynBind (PSB { psb_id = L _ n | otherwise = sels
, psb_args = RecordPatSyn as })) <- bind
= (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss)
| L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
= (sels, L bind_loc n : pss)
| otherwise
= (sels, pss)
------------------- -------------------
hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name]) hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
......
...@@ -71,7 +71,7 @@ templateHaskellNames = [ ...@@ -71,7 +71,7 @@ templateHaskellNames = [
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataInstDName, newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName, infixLDName, infixRDName, infixNDName,
roleAnnotDName, roleAnnotDName, patSynDName, patSynSigDName,
-- Cxt -- Cxt
cxtName, cxtName,
...@@ -87,6 +87,10 @@ templateHaskellNames = [ ...@@ -87,6 +87,10 @@ templateHaskellNames = [
bangTypeName, bangTypeName,
-- VarBangType -- VarBangType
varBangTypeName, varBangTypeName,
-- PatSynDir (for pattern synonyms)
unidirPatSynName, implBidirPatSynName, explBidirPatSynName,
-- PatSynArgs (for pattern synonyms)
prefixPatSynName, infixPatSynName, recordPatSynName,
-- Type -- Type
forallTName, varTName, conTName, appTName, equalityTName, forallTName, varTName, conTName, appTName, equalityTName,
tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
...@@ -325,10 +329,10 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, ...@@ -325,10 +329,10 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, forImpDName, pragInlDName, instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
pragSpecDName, pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
standaloneDerivDName, defaultSigDName, standaloneDerivDName, defaultSigDName, dataInstDName, newtypeInstDName,
dataInstDName, newtypeInstDName, tySynInstDName, tySynInstDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName,
infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name patSynSigDName :: Name
funDName = libFun (fsLit "funD") funDIdKey funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey
...@@ -336,8 +340,7 @@ newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey ...@@ -336,8 +340,7 @@ newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey classDName = libFun (fsLit "classD") classDIdKey
instanceWithOverlapDName instanceWithOverlapDName
= libFun (fsLit "instanceWithOverlapD") = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
instanceWithOverlapDIdKey
standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
...@@ -358,6 +361,8 @@ infixLDName = libFun (fsLit "infixLD") infixLDIdKey ...@@ -358,6 +361,8 @@ infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey infixNDName = libFun (fsLit "infixND") infixNDIdKey
roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
patSynDName = libFun (fsLit "patSynD") patSynDIdKey
patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey
-- type Ctxt = ... -- type Ctxt = ...
cxtName :: Name cxtName :: Name
...@@ -396,6 +401,18 @@ bangTypeName = libFun (fsLit "bangType") bangTKey ...@@ -396,6 +401,18 @@ bangTypeName = libFun (fsLit "bangType") bangTKey
varBangTypeName :: Name varBangTypeName :: Name
varBangTypeName = libFun (fsLit "varBangType") varBangTKey varBangTypeName = libFun (fsLit "varBangType") varBangTKey
-- data PatSynDir = ...
unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name
unidirPatSynName = libFun (fsLit "unidir") unidirPatSynIdKey
implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey
explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey
-- data PatSynArgs = ...
prefixPatSynName, infixPatSynName, recordPatSynName :: Name
prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey
infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey
recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ... -- data Type = ...
forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
listTName, appTName, sigTName, equalityTName, litTName, listTName, appTName, sigTName, equalityTName, litTName,
...@@ -557,7 +574,6 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey ...@@ -557,7 +574,6 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey
overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey
incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
{- *************************************