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
......@@ -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 loc (InlineSig nm ispec)) = rep_inline nm ispec loc
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 _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
......@@ -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
......@@ -1073,11 +1098,11 @@ repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
; repVarOrCon x str }
Nothing -> do { str <- globalVar x
; repVarOrCon x str }
Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr 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 _ (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)
......@@ -725,9 +752,9 @@ cvtl e = wrapL (cvt e)
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
| otherwise = do { l' <- cvtLit l; return $ HsLit l' }
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
; return $ HsApp x' y' }
; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
......@@ -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])
......
......@@ -71,7 +71,7 @@ templateHaskellNames = [
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
dataInstDName, newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName,
roleAnnotDName,
roleAnnotDName, patSynDName, patSynSigDName,
-- Cxt
cxtName,
......@@ -87,6 +87,10 @@ templateHaskellNames = [
bangTypeName,
-- VarBangType
varBangTypeName,
-- PatSynDir (for pattern synonyms)
unidirPatSynName, implBidirPatSynName, explBidirPatSynName,
-- PatSynArgs (for pattern synonyms)
prefixPatSynName, infixPatSynName, recordPatSynName,
-- Type
forallTName, varTName, conTName, appTName, equalityTName,
tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
......@@ -325,10 +329,10 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
standaloneDerivDName, defaultSigDName,
dataInstDName, newtypeInstDName, tySynInstDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
standaloneDerivDName, defaultSigDName, dataInstDName, newtypeInstDName,
tySynInstDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
infixLDName, infixRDName, infixNDName, roleAnnotDName, patSynDName,
patSynSigDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
......@@ -336,8 +340,7 @@ newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey
instanceWithOverlapDName
= libFun (fsLit "instanceWithOverlapD")
instanceWithOverlapDIdKey
= libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
standaloneDerivDName = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
......@@ -358,6 +361,8 @@ infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey
roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
patSynDName = libFun (fsLit "patSynD") patSynDIdKey
patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey
-- type Ctxt = ...
cxtName :: Name
......@@ -396,6 +401,18 @@ bangTypeName = libFun (fsLit "bangType") bangTKey
varBangTypeName :: Name
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 = ...
forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
listTName, appTName, sigTName, equalityTName, litTName,
......@@ -557,7 +574,6 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey
overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey
incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
{- *********************************************************************
* *
Class keys
......@@ -663,8 +679,6 @@ overlappingDataConKey = mkPreludeDataConUnique 110
overlapsDataConKey = mkPreludeDataConUnique 111
incoherentDataConKey = mkPreludeDataConUnique 112
{- *********************************************************************
* *
Id keys
......@@ -713,8 +727,9 @@ liftStringIdKey :: Unique
liftStringIdKey = mkPreludeMiscIdUnique 230
-- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey,
tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey,
sigPIdKey, viewPIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 240
varPIdKey = mkPreludeMiscIdUnique 241
tupPIdKey = mkPreludeMiscIdUnique 242
......@@ -782,99 +797,114 @@ unboundVarEIdKey = mkPreludeMiscIdUnique 297
-- type FieldExp = ...
fieldExpIdKey :: Unique
fieldExpIdKey = mkPreludeMiscIdUnique 310
fieldExpIdKey = mkPreludeMiscIdUnique 305
-- data Body = ...
guardedBIdKey, normalBIdKey :: Unique
guardedBIdKey = mkPreludeMiscIdUnique 311
normalBIdKey = mkPreludeMiscIdUnique 312
guardedBIdKey = mkPreludeMiscIdUnique 306
normalBIdKey = mkPreludeMiscIdUnique 307
-- data Guard = ...
normalGEIdKey, patGEIdKey :: Unique
normalGEIdKey = mkPreludeMiscIdUnique 313
patGEIdKey = mkPreludeMiscIdUnique 314
normalGEIdKey = mkPreludeMiscIdUnique 308
patGEIdKey = mkPreludeMiscIdUnique 309
-- data Stmt = ...
bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
bindSIdKey = mkPreludeMiscIdUnique 320
letSIdKey = mkPreludeMiscIdUnique 321
noBindSIdKey = mkPreludeMiscIdUnique 322
parSIdKey = mkPreludeMiscIdUnique 323
bindSIdKey = mkPreludeMiscIdUnique 310
letSIdKey = mkPreludeMiscIdUnique 311
noBindSIdKey = mkPreludeMiscIdUnique 312
parSIdKey = mkPreludeMiscIdUnique 313
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
classDIdKey, instanceWithOverlapDIdKey, sigDIdKey, forImpDIdKey,
pragInlDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey,
closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
standaloneDerivDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey,
roleAnnotDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330
valDIdKey = mkPreludeMiscIdUnique 331
dataDIdKey = mkPreludeMiscIdUnique 332
newtypeDIdKey = mkPreludeMiscIdUnique 333
tySynDIdKey = mkPreludeMiscIdUnique 334
classDIdKey = mkPreludeMiscIdUnique 335
instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 336
sigDIdKey = mkPreludeMiscIdUnique 337
forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339
pragSpecDIdKey = mkPreludeMiscIdUnique 340
pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
pragSpecInstDIdKey = mkPreludeMiscIdUnique 342
pragRuleDIdKey = mkPreludeMiscIdUnique 343
pragAnnDIdKey = mkPreludeMiscIdUnique 344
dataFamilyDIdKey = mkPreludeMiscIdUnique 345
openTypeFamilyDIdKey = mkPreludeMiscIdUnique 346
dataInstDIdKey = mkPreludeMiscIdUnique 347
newtypeInstDIdKey = mkPreludeMiscIdUnique 348
tySynInstDIdKey = mkPreludeMiscIdUnique 349
closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 350
infixLDIdKey = mkPreludeMiscIdUnique 352
infixRDIdKey = mkPreludeMiscIdUnique 353
infixNDIdKey = mkPreludeMiscIdUnique 354
roleAnnotDIdKey = mkPreludeMiscIdUnique 355
standaloneDerivDIdKey = mkPreludeMiscIdUnique 356
defaultSigDIdKey = mkPreludeMiscIdUnique 357
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, infixLDIdKey,
infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
newtypeDIdKey = mkPreludeMiscIdUnique 323
tySynDIdKey = mkPreludeMiscIdUnique 324
classDIdKey = mkPreludeMiscIdUnique 325
instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326
instanceDIdKey = mkPreludeMiscIdUnique 327
sigDIdKey = mkPreludeMiscIdUnique 328
forImpDIdKey = mkPreludeMiscIdUnique 329
pragInlDIdKey = mkPreludeMiscIdUnique 330
pragSpecDIdKey = mkPreludeMiscIdUnique 331
pragSpecInlDIdKey = mkPreludeMiscIdUnique 332
pragSpecInstDIdKey = mkPreludeMiscIdUnique 333
pragRuleDIdKey = mkPreludeMiscIdUnique 334
pragAnnDIdKey = mkPreludeMiscIdUnique 335
dataFamilyDIdKey = mkPreludeMiscIdUnique 336
openTypeFamilyDIdKey = mkPreludeMiscIdUnique 337
dataInstDIdKey = mkPreludeMiscIdUnique 338
newtypeInstDIdKey = mkPreludeMiscIdUnique 339
tySynInstDIdKey = mkPreludeMiscIdUnique 340
closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341
infixLDIdKey = mkPreludeMiscIdUnique 342
infixRDIdKey = mkPreludeMiscIdUnique 343
infixNDIdKey = mkPreludeMiscIdUnique 344
roleAnnotDIdKey = mkPreludeMiscIdUnique 345
standaloneDerivDIdKey = mkPreludeMiscIdUnique 346
defaultSigDIdKey = mkPreludeMiscIdUnique 347
patSynDIdKey = mkPreludeMiscIdUnique 348
patSynSigDIdKey = mkPreludeMiscIdUnique 349
-- type Cxt = ...
cxtIdKey :: Unique
cxtIdKey = mkPreludeMiscIdUnique 360
cxtIdKey = mkPreludeMiscIdUnique 350
-- data SourceUnpackedness = ...
noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
noSourceUnpackednessKey = mkPreludeMiscIdUnique 361
sourceNoUnpackKey = mkPreludeMiscIdUnique 362
sourceUnpackKey = mkPreludeMiscIdUnique 363
noSourceUnpackednessKey = mkPreludeMiscIdUnique 351
sourceNoUnpackKey = mkPreludeMiscIdUnique 352
sourceUnpackKey = mkPreludeMiscIdUnique 353
-- data SourceStrictness = ...
noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
noSourceStrictnessKey = mkPreludeMiscIdUnique 364
sourceLazyKey = mkPreludeMiscIdUnique 365
sourceStrictKey = mkPreludeMiscIdUnique 366
noSourceStrictnessKey = mkPreludeMiscIdUnique 354
sourceLazyKey = mkPreludeMiscIdUnique 355
sourceStrictKey = mkPreludeMiscIdUnique 356
-- data Con = ...
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
recGadtCIdKey :: Unique
normalCIdKey = mkPreludeMiscIdUnique 370
recCIdKey = mkPreludeMiscIdUnique 371
infixCIdKey = mkPreludeMiscIdUnique 372
forallCIdKey = mkPreludeMiscIdUnique 373
gadtCIdKey = mkPreludeMiscIdUnique 374
recGadtCIdKey = mkPreludeMiscIdUnique 375
normalCIdKey = mkPreludeMiscIdUnique 357
recCIdKey = mkPreludeMiscIdUnique 358
infixCIdKey = mkPreludeMiscIdUnique 359
forallCIdKey = mkPreludeMiscIdUnique 360
gadtCIdKey = mkPreludeMiscIdUnique 361
recGadtCIdKey = mkPreludeMiscIdUnique 362
-- data Bang = ...
bangIdKey :: Unique
bangIdKey = mkPreludeMiscIdUnique 376
bangIdKey = mkPreludeMiscIdUnique 363
-- type BangType = ...
bangTKey :: Unique
bangTKey = mkPreludeMiscIdUnique 377
bangTKey = mkPreludeMiscIdUnique 364
-- type VarBangType = ...
varBangTKey :: Unique
varBangTKey = mkPreludeMiscIdUnique 378
varBangTKey = mkPreludeMiscIdUnique 365
-- data PatSynDir = ...
unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
unidirPatSynIdKey = mkPreludeMiscIdUnique 366
implBidirPatSynIdKey = mkPreludeMiscIdUnique 367
explBidirPatSynIdKey = mkPreludeMiscIdUnique 368
-- data PatSynArgs = ...
prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
prefixPatSynIdKey = mkPreludeMiscIdUnique 369
infixPatSynIdKey = mkPreludeMiscIdUnique 370
recordPatSynIdKey = mkPreludeMiscIdUnique 371
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
......
......@@ -89,7 +89,7 @@ import LoadIface
import Class
import TyCon
import CoAxiom
import PatSyn ( patSynName )
import PatSyn
import ConLike
import DataCon