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
, hs_ruleds = ruleds
, hs_vects = vects
, hs_docs = docs })
= do { let { tv_bndrs = hsSigTvBinders valds
; bndrs = tv_bndrs ++ hsGroupBinders group
= do { let { bndrs = hsSigTvBinders valds
++ hsGroupBinders group
++ hsPatSynSelectors valds
; instds = tyclds >>= group_instds } ;
ss <- mkGenSyms bndrs ;
......@@ -197,7 +198,6 @@ hsSigTvBinders binds
ValBindsIn _ sigs -> sigs
ValBindsOut _ sigs -> sigs
{- Notes
Note [Scoped type variables in bindings]
......@@ -700,7 +700,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
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 _ (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))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms
......@@ -720,6 +720,16 @@ rep_ty_sig mk_sig loc sig_ty nm
; sig <- repProto mk_sig nm1 ty1
; 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
-> DsM (SrcSpan, Core TH.DecQ)
-- We must special-case the top-level explicit for-all of a TypeSig
......@@ -889,17 +899,32 @@ repHsSigType (HsIB { hsib_vars = vars
then return 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 ib_ty@(HsIB { hsib_body = sig1 })
= repHsSigType (ib_ty { hsib_body = hswc_body sig1 })
-- yield the representation of a list of types
--
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
-- represent a type
--
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty
......@@ -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 _ (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
-- all the variables simultaneously. For example:
......
......@@ -350,6 +350,33 @@ cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; 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 tc (TySynEqn lhs rhs)
......@@ -1276,6 +1303,27 @@ cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
; annRHS' <- mapM tNameL 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 prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir)
......@@ -1474,3 +1522,59 @@ the way System Names are printed.
There's a small complication of course; see Note [Looking up Exact
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)
--------------------------------
splitLHsPatSynTy :: LHsType name
-> ( [LHsTyVarBndr name]
, LHsContext name -- Required
, LHsContext name -- Provided
, LHsType name) -- Body
splitLHsPatSynTy ty
| L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1
, 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)
-> ( [LHsTyVarBndr name] -- universals
, LHsContext name -- required constraints
, [LHsTyVarBndr name] -- existentials
, LHsContext name -- provided constraints
, LHsType name) -- body type
splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)
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 ty
......
......@@ -78,7 +78,7 @@ module HsUtils(
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
hsDataDefnBinders,
......@@ -784,8 +784,9 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
if omitPatSyn then acc else ps : acc
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
| otherwise = ps : acc
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
......@@ -935,26 +936,19 @@ hsForeignDeclsBinders foreign_decls
| L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
-------------------
hsPatSynBinders :: HsValBinds RdrName
-> ([Located RdrName], [Located RdrName])
-- Collect pattern-synonym binders only, not Ids
-- See Note [SrcSpan for binders]
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
hsPatSynBinders _ = panic "hsPatSynBinders"
addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
-> ([Located id], [Located id]) -- (selectors, other)
-- See Note [SrcSpan for binders]
addPatSynBndr bind (sels, pss)
| L bind_loc (PatSynBind (PSB { psb_id = L _ n
, 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)
hsPatSynSelectors :: HsValBinds id -> [id]
-- Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by collectHsValBinders.
hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
hsPatSynSelectors (ValBindsOut binds _)
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind id -> [id] -> [id]
addPatSynSelector bind sels
| L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
= map (unLoc . recordPatSynSelectorId) as ++ sels
| otherwise = sels
-------------------
hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
......
This diff is collapsed.
......@@ -89,7 +89,7 @@ import LoadIface
import Class
import TyCon
import CoAxiom
import PatSyn ( patSynName )
import PatSyn
import ConLike
import DataCon
import TcEvidence( TcEvBinds(..) )
......@@ -1272,8 +1272,11 @@ reifyThing (AGlobal (AConLike (RealDataCon dc)))
; return (TH.DataConI (reifyName name) ty
(reifyName (dataConOrigTyCon dc)))
}
reifyThing (AGlobal (AConLike (PatSynCon ps)))
= noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
= do { let name = reifyName ps
; ty <- reifyPatSynType (patSynSig ps)
; return (TH.PatSynI name ty) }
reifyThing (ATcId {tct_id = id})
= do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
......@@ -1636,6 +1639,20 @@ reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
reifyPatSynType
:: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
-- reifies a pattern synonym's type and returns its *complete* type
-- signature; see NOTE [Pattern synonym signatures and Template
-- Haskell]
reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
= do { univTyVars' <- reifyTyVars univTyVars Nothing
; req' <- reifyCxt req
; exTyVars' <- reifyTyVars exTyVars Nothing
; prov' <- reifyCxt prov
; tau' <- reifyType (mkFunTys argTys resTy)
; return $ TH.ForallT univTyVars' req'
$ TH.ForallT exTyVars' prov' tau' }
reifyKind :: Kind -> TcM TH.Kind
reifyKind ki
= do { let (kis, ki') = splitFunTys ki
......
......@@ -59,6 +59,8 @@ instance Binary TH.Clause
instance Binary TH.InjectivityAnn
instance Binary TH.FamilyResultSig
instance Binary TH.TypeFamilyHead
instance Binary TH.PatSynDir
instance Binary TH.PatSynArgs
-- We need Binary TypeRep for serializing annotations
......
......@@ -73,20 +73,22 @@ module Language.Haskell.TH(
Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..),
Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
PatSynDir(..), PatSynArgs(..),
-- ** Expressions
Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
-- ** Patterns
Pat(..), FieldExp, FieldPat,
-- ** Types
Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),
FamilyResultSig(..), Syntax.InjectivityAnn(..),
FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType,
-- * Library functions
-- ** Abbreviations
InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ,
ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ,
SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, StrictTypeQ,
VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ,
VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ,
PatSynArgsQ,
-- ** Constructors lifted to 'Q'
-- *** Literals
......@@ -160,6 +162,10 @@ module Language.Haskell.TH(
pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
pragLineD,
-- **** Pattern Synonyms
patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,
infixPatSyn, recordPatSyn,
-- * Pretty-printer
Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
......
......@@ -46,6 +46,8 @@ type VarStrictTypeQ = Q VarStrictType
type FieldExpQ = Q FieldExp
type RuleBndrQ = Q RuleBndr
type TySynEqnQ = Q TySynEqn
type PatSynDirQ = Q PatSynDir
type PatSynArgsQ = Q PatSynArgs
-- must be defined here for DsMeta to find it
type Role = TH.Role
......@@ -531,6 +533,20 @@ defaultSigD n tyq =
ty <- tyq
return $ DefaultSigD n ty
-- | Pattern synonym declaration
patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD name args dir pat = do
args' <- args
dir' <- dir
pat' <- pat
return (PatSynD name args' dir' pat')
-- | Pattern synonym type signature
patSynSigD :: Name -> TypeQ -> DecQ
patSynSigD nm ty =
do ty' <- ty
return $ PatSynSigD nm ty'
tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
tySynEqn lhs rhs =
do
......@@ -706,8 +722,6 @@ numTyLit n = if n >= 0 then return (NumTyLit n)
strTyLit :: String -> TyLitQ
strTyLit s = return (StrTyLit s)
-------------------------------------------------------------------------------
-- * Kind
......@@ -818,6 +832,27 @@ typeAnnotation = TypeAnnotation
moduleAnnotation :: AnnTarget
moduleAnnotation = ModuleAnnotation
-------------------------------------------------------------------------------
-- * Pattern Synonyms (sub constructs)
unidir, implBidir :: PatSynDirQ
unidir = return Unidir
implBidir = return ImplBidir
explBidir :: [ClauseQ] -> PatSynDirQ
explBidir cls = do
cls' <- sequence cls
return (ExplBidir cls')
prefixPatSyn :: [Name] -> PatSynArgsQ
prefixPatSyn args = return $ PrefixPatSyn args
recordPatSyn :: [Name] -> PatSynArgsQ
recordPatSyn sels = return $ RecordPatSyn sels
infixPatSyn :: Name -> Name -> PatSynArgsQ
infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2
--------------------------------------------------------------
-- * Useful helper function
......
......@@ -59,6 +59,7 @@ instance Ppr Info where
= text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
ppr (DataConI v ty tc)
= text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
ppr (PatSynI nm ty) = pprPatSynSig nm ty
ppr (TyVarI v ty)
= text "Type variable" <+> ppr v <+> equals <+> ppr ty
ppr (VarI v ty mb_d)
......@@ -75,6 +76,24 @@ pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
ppr_fix InfixL = text "infixl"
ppr_fix InfixN = text "infix"
-- | Pretty prints a pattern synonym type signature
pprPatSynSig :: Name -> PatSynType -> Doc
pprPatSynSig nm ty
= text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty
-- | Pretty prints a pattern synonym's type; follows the usual
-- conventions to print a pattern synonym type compactly, yet
-- unambiguously. See the note on 'PatSynType' and the section on
-- pattern synonyms in the GHC users guide for more information.
pprPatSynType :: PatSynType -> Doc
pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
| null exTys, null provs = ppr (ForallT uniTys reqs ty'')
| null uniTys, null reqs = noreqs <+> ppr ty'
| null reqs = forall uniTys <+> noreqs <+> ppr ty'
| otherwise = ppr ty
where noreqs = text "() =>"
forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."
pprPatSynType ty = ppr ty
------------------------------
instance Ppr Module where
......@@ -330,15 +349,22 @@ ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
where
ppr_eqn (TySynEqn lhs rhs)
= ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
ppr_dec _ (RoleAnnotD name roles)
= hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
ppr_dec _ (StandaloneDerivD cxt ty)
= hsep [ text "deriving instance", pprCxt cxt, ppr ty ]
ppr_dec _ (DefaultSigD n ty)
= hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
ppr_dec _ (PatSynD name args dir pat)
= text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS
where
pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2
| otherwise = ppr name <+> ppr args
pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
nestDepth (ppr name <+> ppr cls)
| otherwise = ppr pat
ppr_dec _ (PatSynSigD name ty)
= pprPatSynSig name ty
ppr_overlap :: Overlap -> Doc
......@@ -533,13 +559,28 @@ instance Ppr Con where
ppr (RecGadtC c vsts ty)
= commaSepApplied c <+> dcolon <+> pprRecFields vsts ty
instance Ppr PatSynDir where
ppr Unidir = text "<-"
ppr ImplBidir = text "="
ppr (ExplBidir _) = text "<-"
-- the ExplBidir's clauses are pretty printed together with the
-- entire pattern synonym; so only print the direction here.
instance Ppr PatSynArgs where
ppr (PrefixPatSyn args) = sep $ map ppr args
ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2
ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))
commaSepApplied :: [Name] -> Doc
commaSepApplied = commaSepWith (pprName' Applied)
pprForall :: [TyVarBndr] -> Cxt -> Doc
pprForall ns ctxt
= text "forall" <+> hsep (map ppr ns)
<+> char '.' <+> pprCxt ctxt
pprForall tvs cxt
-- even in the case without any tvs, there could be a non-empty
-- context cxt (e.g., in the case of pattern synonyms, where there
-- are multiple forall binders and contexts).
| [] <- tvs = pprCxt cxt
| otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt
pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields vsts ty
......@@ -639,9 +680,7 @@ pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
pprUInfixT t = ppr t
instance Ppr Type where
ppr (ForallT tvars ctxt ty)
= text "forall" <+> hsep (map ppr tvars) <+> text "."
<+> sep [pprCxt ctxt, ppr ty]
ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
ppr ty = pprTyApp (split ty)
-- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
-- See Note [Pretty-printing kind signatures]
......
......@@ -1231,6 +1231,11 @@ data Info
Type
ParentName
-- | A pattern synonym.
| PatSynI
Name
PatSynType
{- |
A \"value\" variable (as opposed to a type variable, see 'TyVarI').
......@@ -1548,6 +1553,18 @@ data Dec
| RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
| StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@
| DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
-- | Pattern Synonyms
| PatSynD Name PatSynArgs PatSynDir Pat
-- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or
-- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or
-- @{ pattern P v1 v2 .. vn <- p
-- where P v1 v2 .. vn = e }@ explicit bidirectional
--
-- also, besides prefix pattern synonyms, both infix and record
-- pattern synonyms are supported. See 'PatSynArgs' for details
| PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature.
deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- | Varieties of allowed instance overlap.
......@@ -1559,11 +1576,58 @@ data Overlap = Overlappable -- ^ May be overlapped by more specific instances
-- available.
deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
-- By analogy with with "head" for type classes and type class instances as
-- | A Pattern synonym's type. Note that a pattern synonym's *fully*
-- specified type has a peculiar shape coming with two forall
-- quantifiers and two constraint contexts. For example, consider the
-- pattern synonym
--
-- pattern P x1 x2 ... xn = <some-pattern>
--
-- P's complete type is of the following form
--
-- forall universals. required constraints
-- => forall existentials. provided constraints
-- => t1 -> t2 -> ... -> tn -> t
--
-- consisting of four parts:
--
-- 1) the (possibly empty lists of) universally quantified type
-- variables and required constraints on them.
-- 2) the (possibly empty lists of) existentially quantified