Commit b1386942 authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

TTG for HsBinds and Data instances Plan B

Summary:
- Add the balance of the TTG extensions for hsSyn/HsBinds

- Move all the (now orphan) data instances into hsSyn/HsInstances and
use TTG Data instances Plan B
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB

Updates haddock submodule.

Illustrative numbers

Compiling HsInstances before using Plan B.

Max residency ~ 5G
<<ghc: 629,864,691,176 bytes, 5300 GCs,
       321075437/1087762592 avg/max bytes residency (23 samples),
       2953M in use, 0.000 INIT (0.000 elapsed),
       383.511 MUT (384.986 elapsed), 37.426 GC (37.444 elapsed) :ghc>>

Using Plan B

Max residency 1.1G

<<ghc: 78,832,782,968 bytes, 2884 GCs,
       222140352/386470152 avg/max bytes residency (34 samples),
       1062M in use, 0.001 INIT (0.001 elapsed),
       56.612 MUT (62.917 elapsed), 32.974 GC (32.923 elapsed) :ghc>>

Test Plan: ./validate

Reviewers: shayan-najd, goldfire, bgamari

Subscribers: goldfire, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4581
parent 5417c689
......@@ -351,6 +351,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick
......@@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
addTickHsLocalBinds (HsValBinds x binds) =
liftM (HsValBinds x)
(addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds) =
liftM HsIPBinds
addTickHsLocalBinds (HsIPBinds x binds) =
liftM (HsIPBinds x)
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x)
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
......@@ -801,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
addTickHsIPBinds (IPBinds dictbinds ipbinds) =
liftM2 IPBinds
(mapM (liftL (addTickIPBind)) ipbinds)
(return dictbinds)
(mapM (liftL (addTickIPBind)) ipbinds)
addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind nm e) =
liftM2 IPBind
addTickIPBind (IPBind x nm e) =
liftM2 (IPBind x)
(return nm)
(addTickLHsExpr e)
addTickIPBind (XCIPBind x) = return (XCIPBind x)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
......
......@@ -163,7 +163,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
return (force_var, [core_binds]) }
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_rhs_ty = ty
, pat_ext = NPatBindTc _ ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; checkGuardMatches PatBindGuards grhss
......@@ -192,6 +192,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
-----------------------
......@@ -251,6 +252,7 @@ dsAbsBinds dflags tyvars dicts exports
; return (makeCorePair dflags global
(isDefaultMethod prags)
0 (core_wrap (Var local))) }
mk_bind (XABExport _) = panic "dsAbsBinds"
; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
......@@ -295,6 +297,7 @@ dsAbsBinds dflags tyvars dicts exports
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) }
mk_bind (XABExport _) = panic "dsAbsBinds"
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
......@@ -342,7 +345,8 @@ dsAbsBinds dflags tyvars dicts exports
mk_export local =
do global <- newSysLocalDs
(exprType (mkLams tyvars (mkLams dicts (Var local))))
return (ABE { abe_poly = global
return (ABE { abe_ext = noExt
, abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
, abe_prags = SpecPrags [] })
......
......@@ -71,10 +71,11 @@ import Control.Monad
-}
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L _ EmptyLocalBinds) body = return body
dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body
dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
dsLocalBinds (L _ (XHsLocalBindsLR _)) _ = panic "dsLocalBinds"
-------------------------
-- caller sets location
......@@ -85,16 +86,18 @@ dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds ip_binds ev_binds) body
dsIPBinds (IPBinds ev_binds ip_binds) body
= do { ds_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_binds body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
ds_ip_bind (L _ (IPBind ~(Right n) e)) body
ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
ds_ip_bind (L _ (XCIPBind _)) _ = panic "dsIPBinds"
dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
-------------------------
-- caller sets location
......@@ -201,7 +204,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun
; let rhs' = mkOptTickBox tick rhs
; return (bindNonRec fun rhs' body) }
dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
, pat_ext = NPatBindTc _ ty }) body
= -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
do { rhs <- dsGuarded grhss ty
......
......@@ -193,11 +193,11 @@ hsSigTvBinders binds
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
| TypeSig _ sig <- signature
| TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig)
| ClassOpSig _ _ sig <- signature
| ClassOpSig _ _ _ sig <- signature
= get_scoped_tvs_from_sig sig
| PatSynSig _ sig <- signature
| PatSynSig _ _ sig <- signature
= get_scoped_tvs_from_sig sig
| otherwise
= []
......@@ -602,7 +602,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity _ prec dir)))
repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
......@@ -613,6 +613,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir)))
; dec <- rep2 rep_fn [prec', name']
; return (loc,dec) }
; mapM do_one names }
repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
......@@ -771,20 +772,21 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> 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 (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
rep_sig (L loc (ClassOpSig is_deflt nms ty))
rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
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
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))
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
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 _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc
rep_sig (L _ (XSig _)) = panic "rep_sig"
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
......@@ -1445,13 +1447,13 @@ repSts other = notHandled "Exotic statement" (ppr other)
-----------------------------------------------------------
repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
repBinds EmptyLocalBinds
repBinds (EmptyLocalBinds _)
= do { core_list <- coreList decQTyConName []
; return ([], core_list) }
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds b@(HsIPBinds {}) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
repBinds (HsValBinds _ decs)
= do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
-- No need to worry about detailed scopes within
-- the binding group, because we are talking Names
......@@ -1463,6 +1465,7 @@ repBinds (HsValBinds decs)
; core_list <- coreList decQTyConName
(de_loc (sort_by_loc prs))
; return (ss, core_list) }
repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are already in the meta-env
......@@ -1521,11 +1524,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; return (srcLocSpan (getSrcLoc v), ans) }
rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L loc (PatSynBind (PSB { psb_id = syn
, psb_fvs = _fvs
, psb_args = args
, psb_def = pat
, psb_dir = dir })))
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
......@@ -1560,6 +1563,9 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"
repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ
-> Core TH.PatSynDirQ
......@@ -1628,7 +1634,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match { m_pats = ps
, m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } ))
, m_grhss = GRHSs [L _ (GRHS [] e)]
(L _ (EmptyLocalBinds _)) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
......
......@@ -320,6 +320,7 @@ Library
HsLit
PlaceHolder
HsExtension
HsInstances
HsPat
HsSyn
HsTypes
......
......@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
; ds' <- cvtLocalDecs (text "a where clause") ds
; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
, pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
, pat_ext = noExt
, pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls)
......@@ -169,7 +169,7 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
; returnJustL $ Hs.SigD (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm)
-- Fixity signatures are allowed for variables, constructors, and types
......@@ -177,7 +177,8 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm
; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
; returnJustL (Hs.SigD (FixSig noExt
(FixitySig noExt [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
......@@ -358,15 +359,15 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
; returnJustL $ Hs.SigD $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
; args' <- cvtArgs args
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind $
PSB nm' placeHolderType args' pat' dir' }
; returnJustL $ Hs.ValD $ PatSynBind noExt $
PSB noExt nm' placeHolderType args' pat' dir' }
where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
......@@ -384,7 +385,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
; returnJustL $ Hs.SigD $ PatSynSig noExt [nm'] (mkLHsSigType ty') }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
......@@ -651,7 +652,7 @@ cvtPragmaD (InlineP nm inline rm phases)
, inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ InlineSig nm' ip }
; returnJustL $ Hs.SigD $ InlineSig noExt nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
......@@ -669,12 +670,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
; returnJustL $ Hs.SigD $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
; returnJustL $ Hs.SigD $
SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
cvtPragmaD (RuleP nm bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
......@@ -711,7 +712,7 @@ cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls
; mty' <- traverse tconNameL mty
; returnJustL $ Hs.SigD
$ CompleteMatchSig NoSourceText cls' mty' }
$ CompleteMatchSig noExt NoSourceText cls' mty' }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
......@@ -747,13 +748,13 @@ cvtRuleBndr (TypedRuleVar n ty)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc ds
| null ds
= return EmptyLocalBinds
= return (EmptyLocalBinds noExt)
| otherwise
= do { ds' <- cvtDecs ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) }
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
......
This diff is collapsed.
......@@ -132,6 +132,7 @@ type LHsDecl id = Located (HsDecl id)
-- | A Haskell Declaration
data HsDecl id
-- AZ:TODO:TTG HsDecl
= TyClD (TyClDecl id) -- ^ Type or Class Declaration
| InstD (InstDecl id) -- ^ Instance declaration
| DerivD (DerivDecl id) -- ^ Deriving declaration
......@@ -147,7 +148,6 @@ data HsDecl id
-- (Includes quasi-quotes)
| DocD (DocDecl) -- ^ Documentation comment declaration
| RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration
deriving instance (DataIdLR id id) => Data (HsDecl id)
-- NB: all top-level fixity decls are contained EITHER
......@@ -168,6 +168,7 @@ deriving instance (DataIdLR id id) => Data (HsDecl id)
-- A 'HsDecl' is categorised into a 'HsGroup' before being
-- fed to the renamer.
data HsGroup id
-- AZ:TODO:TTG HsGroup
= HsGroup {
hs_valds :: HsValBinds id,
hs_splcds :: [LSpliceDecl id],
......@@ -193,7 +194,6 @@ data HsGroup id
hs_docs :: [LDocDecl]
}
deriving instance (DataIdLR id id) => Data (HsGroup id)
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
......@@ -309,10 +309,10 @@ type LSpliceDecl pass = Located (SpliceDecl pass)
-- | Splice Declaration
data SpliceDecl id
-- AZ:TODO: TTG SpliceD
= SpliceDecl -- Top level splice
(Located (HsSplice id))
SpliceExplicitFlag
deriving instance (DataIdLR id id) => Data (SpliceDecl id)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (SpliceDecl p) where
......@@ -462,6 +462,7 @@ type LTyClDecl pass = Located (TyClDecl pass)
-- | A type or class declaration.
data TyClDecl pass
-- AZ:TODO: TTG TyClDecl
= -- | @type/data family T :: *->*@
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
......@@ -535,8 +536,6 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR id id) => Data (TyClDecl id)
-- Simple classifiers for TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -776,10 +775,10 @@ in RnSource for more info.
-- | Type or Class Group
data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
-- AZ:TODO: TTG TyClGroups
= TyClGroup { group_tyclds :: [LTyClDecl pass]
, group_roles :: [LRoleAnnotDecl pass]
, group_instds :: [LInstDecl pass] }
deriving instance (DataIdLR id id) => Data (TyClGroup id)
emptyTyClGroup :: TyClGroup pass
emptyTyClGroup = TyClGroup [] [] []
......@@ -876,6 +875,7 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass)
-- | type Family Result Signature
data FamilyResultSig pass = -- see Note [FamilyResultSig]
-- AZ:TODO: TTG FamilyResultSig
NoSig
-- ^ - 'ApiAnnotation.AnnKeywordId' :
......@@ -895,8 +895,6 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass)
-- | Located type Family Declaration
type LFamilyDecl pass = Located (FamilyDecl pass)
......@@ -918,8 +916,6 @@ data FamilyDecl pass = FamilyDecl
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR id id) => Data (FamilyDecl id)
-- | Located Injectivity Annotation
type LInjectivityAnn pass = Located (InjectivityAnn pass)
......@@ -937,7 +933,6 @@ data InjectivityAnn pass
-- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (InjectivityAnn pass)
data FamilyInfo pass
= DataFamily
......@@ -945,7 +940,6 @@ data FamilyInfo pass
-- | 'Nothing' if we're in an hs-boot file and the user
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass)
-- | Does this family declaration have a complete, user-supplied kind signature?
famDeclHasCusk :: Maybe Bool
......@@ -1053,7 +1047,6 @@ data HsDataDefn pass -- The payload of a data type defn
-- For details on above see note [Api annotations] in ApiAnnotation
}
deriving instance (DataIdLR id id) => Data (HsDataDefn id)
-- | Haskell Deriving clause
type HsDeriving pass = Located [LHsDerivingClause pass]
......@@ -1089,7 +1082,6 @@ data HsDerivingClause pass
--
-- should produce a derived instance for @C [a] (T b)@.
}
deriving instance (DataIdLR id id) => Data (HsDerivingClause id)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsDerivingClause p) where
......@@ -1183,7 +1175,6 @@ data ConDecl pass
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
}
deriving instance (DataIdLR pass pass) => Data (ConDecl pass)
{- Note [GADT abstract syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1416,7 +1407,6 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-- 'ApiAnnotation.AnnInstance',
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass)
----------------- Data family instances -------------
......@@ -1434,7 +1424,6 @@ newtype DataFamInstDecl pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass)
----------------- Family instances (common types) -------------
......@@ -1464,8 +1453,6 @@ data FamEqn pass pats rhs
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass, Data pats, Data rhs)
=> Data (FamEqn pass pats rhs)
----------------- Class instances -------------
......@@ -1494,8 +1481,6 @@ data ClsInstDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR id id) => Data (ClsInstDecl id)
----------------- Instances of all kinds -------------
......@@ -1510,7 +1495,6 @@ data InstDecl pass -- Both class and family instances
{ dfid_inst :: DataFamInstDecl pass }
| TyFamInstD -- type family instance
{ tfid_inst :: TyFamInstDecl pass }
deriving instance (DataIdLR id id) => Data (InstDecl id)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (TyFamInstDecl p) where
......@@ -1680,7 +1664,6 @@ data DerivDecl pass = DerivDecl
-- For details on above see note [Api annotations] in ApiAnnotation
}
deriving instance (DataIdLR pass pass) => Data (DerivDecl pass)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DerivDecl p) where
......@@ -1715,7 +1698,6 @@ data DefaultDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass)
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (DefaultDecl p) where
......@@ -1759,7 +1741,6 @@ data ForeignDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass)
{-
In both ForeignImport and ForeignExport:
sig_ty is the type given in the Haskell code
......@@ -1876,7 +1857,6 @@ type LRuleDecls pass = Located (RuleDecls pass)
-- | Rule Declarations
data RuleDecls pass = HsRules { rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
deriving instance (DataIdLR pass pass) => Data (RuleDecls pass)
-- | Located Rule Declaration
type LRuleDecl pass = Located (RuleDecl pass)
......@@ -1902,7 +1882,6 @@ data RuleDecl pass
-- 'ApiAnnotation.AnnEqual',
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR pass pass) => Data (RuleDecl pass)
flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
......@@ -1919,7 +1898,6 @@ data RuleBndr pass
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR pass pass) => Data (RuleBndr pass)
collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
......@@ -2010,7 +1988,6 @@ data VectDecl pass
(LHsSigType pass)
| HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
ClsInst
deriving instance (DataIdLR pass pass) => Data (VectDecl pass)
lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name
lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name
......@@ -2108,14 +2085,12 @@ type LWarnDecls pass = Located (WarnDecls pass)
data WarnDecls pass = Warnings { wd_src :: SourceText
, wd_warnings :: [LWarnDecl pass]
}
deriving instance (DataId pass) => Data (WarnDecls pass)
-- | Located Warning pragma Declaration
type LWarnDecl pass = Located (WarnDecl pass)
-- | Warning pragma Declaration
data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt
deriving instance (DataId pass) => Data (WarnDecl pass)
instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where
ppr (Warnings (SourceText src) decls)
......@@ -2148,7 +2123,6 @@ data AnnDecl pass = HsAnnotation