Commit b1386942 authored by Alan Zimmerman's avatar Alan Zimmerman

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.
This diff is collapsed.
......@@ -111,7 +111,6 @@ noPostTcTable = []
data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p
, syn_arg_wraps :: [HsWrapper]
, syn_res_wrap :: HsWrapper }
deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
......@@ -719,14 +718,12 @@ data HsExpr p
| XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor
deriving instance (DataIdLR p p) => Data (HsExpr p)
-- | Extra data fields for a 'RecordCon', added by the type checker
data RecordConTc = RecordConTc
{ rcon_con_like :: ConLike -- The data constructor or pattern synonym
, rcon_con_expr :: PostTcExpr -- Instantiated constructor function
} deriving Data
}
-- | Extra data fields for a 'RecordUpd', added by the type checker
data RecordUpdTc = RecordUpdTc
......@@ -862,7 +859,6 @@ data HsTupArg id
= Present (XPresent id) (LHsExpr id) -- ^ The argument
| Missing (XMissing id) -- ^ The argument is missing, but this is its type
| XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point
deriving instance (DataIdLR id id) => Data (HsTupArg id)
type instance XPresent (GhcPass _) = PlaceHolder
......@@ -1405,7 +1401,6 @@ data HsCmd id
-- wrap :: arg1 "->" arg2
-- Then (HsCmdWrap wrap cmd) :: arg2 --> res
| XCmd (XXCmd id) -- Note [Trees that Grow] extension point
deriving instance (DataIdLR id id) => Data (HsCmd id)
type instance XCmdArrApp GhcPs = PlaceHolder
type instance XCmdArrApp GhcRn = PlaceHolder
......@@ -1444,13 +1439,11 @@ data HsCmdTop p
= HsCmdTop (XCmdTop p)
(LHsCmd p)
| XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point
deriving instance (DataIdLR p p) => Data (HsCmdTop p)
data CmdTopTc
= CmdTopTc Type -- Nested tuple of inputs on the command's stack
Type -- return type of the command
(CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
deriving Data
type instance XCmdTop GhcPs = PlaceHolder
type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
......@@ -1596,7 +1589,6 @@ data MatchGroup p body
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
-- | Located Match
type LMatch id body = Located (Match id body)
......@@ -1612,7 +1604,6 @@ data Match p body
m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
deriving instance (Data body,DataIdLR p p) => Data (Match p body)
instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
=> Outputable (Match idR body) where
......@@ -1698,7 +1689,6 @@ data GRHSs p body
grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs
grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
}
deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body)
-- | Located Guarded Right-Hand Side
type LGRHS id body = Located (GRHS id body)
......@@ -1707,7 +1697,6 @@ type LGRHS id body = Located (GRHS id body)
-- | Guarded Right Hand Side.
data GRHS id body = GRHS [GuardLStmt id] -- Guards
body -- Right hand side
deriving instance (Data body,DataIdLR id id) => Data (GRHS id body)
-- We know the list must have at least one @Match@ in it.
......@@ -1960,8 +1949,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- With rebindable syntax the type might not
-- be quite as simple as (m (tya, tyb, tyc)).
}
deriving instance (Data body, DataIdLR idL idR)
=> Data (StmtLR idL idR body)
data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
= ThenForm -- then f or then f by e (depending on trS_by)
......@@ -1976,7 +1963,6 @@ data ParStmtBlock idL idR
[IdP idR] -- The variables to be returned
(SyntaxExpr idR) -- The return operator
| XParStmtBlock (XXParStmtBlock idL idR)
deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR)
type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder
......@@ -1996,7 +1982,6 @@ data ApplicativeArg idL
(LPat idL) -- (v1,...,vn)
-- AZ: May need to bring back idR?
deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL)
{-
Note [The type of bind in Stmts]
......@@ -2344,7 +2329,6 @@ data HsSplice id
ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing
| XSplice (XXSplice id) -- Note [Trees that Grow] extension point
deriving instance (DataIdLR id id) => Data (HsSplice id)
type instance XTypedSplice (GhcPass _) = PlaceHolder
type instance XUntypedSplice (GhcPass _) = PlaceHolder
......@@ -2391,7 +2375,6 @@ data HsSplicedThing id
| HsSplicedTy (HsType id) -- ^ Haskell Spliced Type
| HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
deriving instance (DataIdLR id id) => Data (HsSplicedThing id)
-- See Note [Pending Splices]
type SplicePointName = Name
......@@ -2400,7 +2383,6 @@ type SplicePointName = Name
data PendingRnSplice
-- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn?
= PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
deriving Data
data UntypedSpliceFlavour
= UntypedExpSplice
......@@ -2413,7 +2395,6 @@ data UntypedSpliceFlavour
data PendingTcSplice
-- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc?
= PendingTcSplice SplicePointName (LHsExpr GhcTc)
deriving Data
{-
Note [Pending Splices]
......@@ -2541,7 +2522,6 @@ data HsBracket p
-- (The Bool flag is used only in pprHsBracket)
| TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
| XBracket (XXBracket p) -- Note [Trees that Grow] extension point
deriving instance (DataIdLR p p) => Data (HsBracket p)
type instance XExpBr (GhcPass _) = PlaceHolder
type instance XPatBr (GhcPass _) = PlaceHolder
......@@ -2605,7 +2585,6 @@ data ArithSeqInfo id
| FromThenTo (LHsExpr id)
(LHsExpr id)
(LHsExpr id)
deriving instance (DataIdLR id id) => Data (ArithSeqInfo id)
-- AZ: Sould ArithSeqInfo have a TTG extension?
instance (p ~ GhcPass pass, OutputableBndrId p)
......
......@@ -13,8 +13,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
import HsExtension ( OutputableBndrId, DataIdLR, GhcPass )
import Data.Data hiding ( Fixity )
import HsExtension ( OutputableBndrId, GhcPass )
type role HsExpr nominal
type role HsCmd nominal
......@@ -29,13 +28,6 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
instance (DataIdLR id id) => Data (HsSplice id)
instance (DataIdLR p p) => Data (HsExpr p)
instance (DataIdLR id id) => Data (HsCmd id)
instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
instance (Data body,DataIdLR p p) => Data (GRHSs p body)
instance (DataIdLR p p) => Data (SyntaxExpr p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
......
This diff is collapsed.
This diff is collapsed.
......@@ -79,8 +79,6 @@ data HsLit x
| XLit (XXLit x)
deriving instance (DataId x) => Data (HsLit x)
type instance XHsChar (GhcPass _) = SourceText
type instance XHsCharPrim (GhcPass _) = SourceText
type instance XHsString (GhcPass _) = SourceText
......@@ -121,7 +119,6 @@ data HsOverLit p
| XOverLit
(XXOverLit p)
deriving instance (DataIdLR p p) => Data (HsOverLit p)
data OverLitTc
= OverLitTc {
......
......@@ -279,7 +279,6 @@ data Pat p
-- | Trees that Grow extension point for new constructors
| XPat
(XXPat p)
deriving instance (DataIdLR p p) => Data (Pat p)
-- ---------------------------------------------------------------------
......@@ -353,7 +352,6 @@ data HsRecFields p arg -- A bunch of record fields
= HsRecFields { rec_flds :: [LHsRecField p arg],
rec_dotdot :: Maybe Int } -- Note [DotDot fields]
deriving (Functor, Foldable, Traversable)
deriving instance (DataId p, Data arg) => Data (HsRecFields p arg)
-- Note [DotDot fields]
......
......@@ -9,13 +9,11 @@
module HsPat where
import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
import HsExtension ( DataIdLR, OutputableBndrId, GhcPass )
import HsExtension ( OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
instance (DataIdLR p p) => Data (Pat p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
......@@ -16,6 +16,7 @@ therefore, is almost nothing but re-exporting.
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data
module HsSyn (
module HsBinds,
......@@ -31,7 +32,7 @@ module HsSyn (
module HsExtension,
Fixity,
HsModule(..)
HsModule(..),
) where
-- friends:
......@@ -49,6 +50,7 @@ import HsTypes
import BasicTypes ( Fixity, WarningTxt )
import HsUtils
import HsDoc
import HsInstances ()
-- others:
import Outputable
......@@ -111,7 +113,10 @@ data HsModule name
-- hsmodImports,hsmodDecls if this style is used.
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataIdLR name name) => Data (HsModule name)
-- deriving instance (DataIdLR name name) => Data (HsModule name)
deriving instance Data (HsModule GhcPs)
deriving instance Data (HsModule GhcRn)
deriving instance Data (HsModule GhcTc)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
......
......@@ -270,7 +270,6 @@ data LHsQTyVars pass -- See Note [HsType binders]
-- See Note [Dependent LHsQTyVars] in TcHsType
}
deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass)
mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs
......@@ -300,7 +299,6 @@ data HsImplicitBndrs pass thing -- See Note [HsType binders]
-- is the payload closed? Used in
-- TcHsType.decideKindGeneralisationPlan
}
deriving instance (DataId pass, Data thing) => Data (HsImplicitBndrs pass thing)
-- | Haskell Wildcard Binders
data HsWildCardBndrs pass thing
......@@ -316,8 +314,6 @@ data HsWildCardBndrs pass thing
-- it's still there in the hsc_body.
}
deriving instance (DataId pass, Data thing) => Data (HsWildCardBndrs pass thing)
-- | Located Haskell Signature Type
type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only
......@@ -420,7 +416,6 @@ data HsTyVarBndr pass
| XTyVarBndr
(XXTyVarBndr pass)
deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass)
type instance XUserTyVar (GhcPass _) = PlaceHolder
type instance XKindedTyVar (GhcPass _) = PlaceHolder
......@@ -627,7 +622,6 @@ data HsType pass
-- For adding new constructors via Trees that Grow
| XHsType
(XXType pass)
deriving instance (DataIdLR pass pass) => Data (HsType pass)
data NewHsTypeX
= NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
......@@ -692,7 +686,6 @@ newtype HsWildCardInfo pass -- See Note [The wildcard story for types]
= AnonWildCard (PostRn pass (Located Name))
-- A anonymous wild card ('_'). A fresh Name is generated for
-- each individual anonymous wildcard during renaming
deriving instance (DataId pass) => Data (HsWildCardInfo pass)
-- | Located Haskell Application Type
type LHsAppType pass = Located (HsAppType pass)
......@@ -706,7 +699,6 @@ data HsAppType pass
(LHsType pass) -- anything else, including things like (+)
| XAppType
(XXAppType pass)
deriving instance (DataIdLR pass pass) => Data (HsAppType pass)
type instance XAppInfix (GhcPass _) = PlaceHolder
type instance XAppPrefix (GhcPass _) = PlaceHolder
......@@ -855,7 +847,6 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'