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 ...@@ -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. -- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick bindTick
...@@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = ...@@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) = addTickHsLocalBinds (HsValBinds x binds) =
liftM HsValBinds liftM (HsValBinds x)
(addTickHsValBinds binds) (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds) = addTickHsLocalBinds (HsIPBinds x binds) =
liftM HsIPBinds liftM (HsIPBinds x)
(addTickHsIPBinds binds) (addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x)
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b)) -> TM (HsValBindsLR GhcTc (GhcPass b))
...@@ -801,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do ...@@ -801,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds (IPBinds ipbinds dictbinds) = addTickHsIPBinds (IPBinds dictbinds ipbinds) =
liftM2 IPBinds liftM2 IPBinds
(mapM (liftL (addTickIPBind)) ipbinds)
(return dictbinds) (return dictbinds)
(mapM (liftL (addTickIPBind)) ipbinds)
addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind nm e) = addTickIPBind (IPBind x nm e) =
liftM2 IPBind liftM2 (IPBind x)
(return nm) (return nm)
(addTickLHsExpr e) (addTickLHsExpr e)
addTickIPBind (XCIPBind x) = return (XCIPBind x)
-- There is no location here, so we might need to use a context location?? -- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
......
...@@ -163,7 +163,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches ...@@ -163,7 +163,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
return (force_var, [core_binds]) } return (force_var, [core_binds]) }
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_rhs_ty = ty , pat_ext = NPatBindTc _ ty
, pat_ticks = (rhs_tick, var_ticks) }) , pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty = do { body_expr <- dsGuarded grhss ty
; checkGuardMatches PatBindGuards grhss ; checkGuardMatches PatBindGuards grhss
...@@ -192,6 +192,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts ...@@ -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 } ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
----------------------- -----------------------
...@@ -251,6 +252,7 @@ dsAbsBinds dflags tyvars dicts exports ...@@ -251,6 +252,7 @@ dsAbsBinds dflags tyvars dicts exports
; return (makeCorePair dflags global ; return (makeCorePair dflags global
(isDefaultMethod prags) (isDefaultMethod prags)
0 (core_wrap (Var local))) } 0 (core_wrap (Var local))) }
mk_bind (XABExport _) = panic "dsAbsBinds"
; main_binds <- mapM mk_bind exports ; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
...@@ -295,6 +297,7 @@ dsAbsBinds dflags tyvars dicts exports ...@@ -295,6 +297,7 @@ dsAbsBinds dflags tyvars dicts exports
-- the user written (local) function. The global -- the user written (local) function. The global
-- Id is just the selector. Hmm. -- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) } ; return ((global', rhs) : fromOL spec_binds) }
mk_bind (XABExport _) = panic "dsAbsBinds"
; export_binds_s <- mapM mk_bind (exports ++ extra_exports) ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
...@@ -342,7 +345,8 @@ dsAbsBinds dflags tyvars dicts exports ...@@ -342,7 +345,8 @@ dsAbsBinds dflags tyvars dicts exports
mk_export local = mk_export local =
do global <- newSysLocalDs do global <- newSysLocalDs
(exprType (mkLams tyvars (mkLams dicts (Var local)))) (exprType (mkLams tyvars (mkLams dicts (Var local))))
return (ABE { abe_poly = global return (ABE { abe_ext = noExt
, abe_poly = global
, abe_mono = local , abe_mono = local
, abe_wrap = WpHole , abe_wrap = WpHole
, abe_prags = SpecPrags [] }) , abe_prags = SpecPrags [] })
......
...@@ -71,10 +71,11 @@ import Control.Monad ...@@ -71,10 +71,11 @@ import Control.Monad
-} -}
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L _ EmptyLocalBinds) body = return body dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
dsValBinds binds body dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
dsLocalBinds (L _ (XHsLocalBindsLR _)) _ = panic "dsLocalBinds"
------------------------- -------------------------
-- caller sets location -- caller sets location
...@@ -85,16 +86,18 @@ dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" ...@@ -85,16 +86,18 @@ dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
------------------------- -------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr 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 = do { ds_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_binds body ; let inner = mkCoreLets ds_binds body
-- The dict bindings may not be in -- The dict bindings may not be in
-- dependency order; hence Rec -- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds } ; foldrM ds_ip_bind inner ip_binds }
where where
ds_ip_bind (L _ (IPBind ~(Right n) e)) body ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e = do e' <- dsLExpr e
return (Let (NonRec n e') body) return (Let (NonRec n e') body)
ds_ip_bind (L _ (XCIPBind _)) _ = panic "dsIPBinds"
dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
------------------------- -------------------------
-- caller sets location -- caller sets location
...@@ -201,7 +204,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun ...@@ -201,7 +204,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun
; let rhs' = mkOptTickBox tick rhs ; let rhs' = mkOptTickBox tick rhs
; return (bindNonRec fun rhs' body) } ; 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 = -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body -- ==> case rhs of C x# y# -> body
do { rhs <- dsGuarded grhss ty do { rhs <- dsGuarded grhss ty
......
...@@ -193,11 +193,11 @@ hsSigTvBinders binds ...@@ -193,11 +193,11 @@ hsSigTvBinders binds
get_scoped_tvs :: LSig GhcRn -> [Name] get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature) get_scoped_tvs (L _ signature)
| TypeSig _ sig <- signature | TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig) = get_scoped_tvs_from_sig (hswc_body sig)
| ClassOpSig _ _ sig <- signature | ClassOpSig _ _ _ sig <- signature
= get_scoped_tvs_from_sig sig = get_scoped_tvs_from_sig sig
| PatSynSig _ sig <- signature | PatSynSig _ _ sig <- signature
= get_scoped_tvs_from_sig sig = get_scoped_tvs_from_sig sig
| otherwise | otherwise
= [] = []
...@@ -602,7 +602,7 @@ repSafety PlayInterruptible = rep2 interruptibleName [] ...@@ -602,7 +602,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName [] repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] 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 = do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of ; let rep_fn = case dir of
InfixL -> infixLDName InfixL -> infixLDName
...@@ -613,6 +613,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir))) ...@@ -613,6 +613,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir)))
; dec <- rep2 rep_fn [prec', name'] ; dec <- rep2 rep_fn [prec', name']
; return (loc,dec) } ; return (loc,dec) }
; mapM do_one names } ; mapM do_one names }
repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
...@@ -771,20 +772,21 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] ...@@ -771,20 +772,21 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sigs = concatMapM rep_sig rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] 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 (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 (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
rep_sig (L loc (ClassOpSig is_deflt nms ty)) rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm tys ispec)) rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys = concatMapM (\t -> rep_specialise nm t ispec loc) tys
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC 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 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-> DsM (SrcSpan, Core TH.DecQ) -> DsM (SrcSpan, Core TH.DecQ)
...@@ -1445,13 +1447,13 @@ repSts other = notHandled "Exotic statement" (ppr other) ...@@ -1445,13 +1447,13 @@ repSts other = notHandled "Exotic statement" (ppr other)
----------------------------------------------------------- -----------------------------------------------------------
repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
repBinds EmptyLocalBinds repBinds (EmptyLocalBinds _)
= do { core_list <- coreList decQTyConName [] = do { core_list <- coreList decQTyConName []
; return ([], core_list) } ; 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 } = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
-- No need to worry about detailed scopes within -- No need to worry about detailed scopes within
-- the binding group, because we are talking Names -- the binding group, because we are talking Names
...@@ -1463,6 +1465,7 @@ repBinds (HsValBinds decs) ...@@ -1463,6 +1465,7 @@ repBinds (HsValBinds decs)
; core_list <- coreList decQTyConName ; core_list <- coreList decQTyConName
(de_loc (sort_by_loc prs)) (de_loc (sort_by_loc prs))
; return (ss, core_list) } ; return (ss, core_list) }
repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are already in the meta-env -- 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})) ...@@ -1521,11 +1524,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; return (srcLocSpan (getSrcLoc v), ans) } ; return (srcLocSpan (getSrcLoc v), ans) }
rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L loc (PatSynBind (PSB { psb_id = syn rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
, psb_fvs = _fvs , psb_fvs = _fvs
, psb_args = args , psb_args = args
, psb_def = pat , psb_def = pat
, psb_dir = dir }))) , psb_dir = dir })))
= do { syn' <- lookupLBinder syn = do { syn' <- lookupLBinder syn
; dir' <- repPatSynDir dir ; dir' <- repPatSynDir dir
; ss <- mkGenArgSyms args ; ss <- mkGenArgSyms args
...@@ -1560,6 +1563,9 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn ...@@ -1560,6 +1563,9 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn
wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss 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 repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ -> Core TH.PatSynArgsQ
-> Core TH.PatSynDirQ -> Core TH.PatSynDirQ
...@@ -1628,7 +1634,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] ...@@ -1628,7 +1634,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match { m_pats = ps 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 ; = do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs ; ss <- mkGenSyms bndrs
; lam <- addBinds ss ( ; lam <- addBinds ss (
......
...@@ -320,6 +320,7 @@ Library ...@@ -320,6 +320,7 @@ Library
HsLit HsLit
PlaceHolder PlaceHolder
HsExtension HsExtension
HsInstances
HsPat HsPat
HsSyn HsSyn
HsTypes HsTypes
......
...@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds) ...@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
; ds' <- cvtLocalDecs (text "a where clause") ds ; ds' <- cvtLocalDecs (text "a where clause") ds
; returnJustL $ Hs.ValD $ ; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds') PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
, pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames , pat_ext = noExt
, pat_ticks = ([],[]) } } , pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls) cvtDec (TH.FunD nm cls)
...@@ -169,7 +169,7 @@ cvtDec (TH.FunD nm cls) ...@@ -169,7 +169,7 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ) cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; ty' <- cvtType typ ; ty' <- cvtType typ
; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } ; returnJustL $ Hs.SigD (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm) cvtDec (TH.InfixD fx nm)
-- Fixity signatures are allowed for variables, constructors, and types -- Fixity signatures are allowed for variables, constructors, and types
...@@ -177,7 +177,8 @@ cvtDec (TH.InfixD fx nm) ...@@ -177,7 +177,8 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume -- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed. -- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm = 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) cvtDec (PragmaD prag)
= cvtPragmaD prag = cvtPragmaD prag
...@@ -358,15 +359,15 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) ...@@ -358,15 +359,15 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
cvtDec (TH.DefaultSigD nm typ) cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; ty' <- cvtType typ ; ty' <- cvtType typ
; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } ; returnJustL $ Hs.SigD $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
cvtDec (TH.PatSynD nm args dir pat) cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm = do { nm' <- cNameL nm
; args' <- cvtArgs args ; args' <- cvtArgs args
; dir' <- cvtDir nm' dir ; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat ; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind $ ; returnJustL $ Hs.ValD $ PatSynBind noExt $
PSB nm' placeHolderType args' pat' dir' } PSB noExt nm' placeHolderType args' pat' dir' }
where where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
...@@ -384,7 +385,7 @@ cvtDec (TH.PatSynD nm args dir pat) ...@@ -384,7 +385,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty) cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm = do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty ; 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) cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
...@@ -651,7 +652,7 @@ cvtPragmaD (InlineP nm inline rm phases) ...@@ -651,7 +652,7 @@ cvtPragmaD (InlineP nm inline rm phases)
, inl_rule = cvtRuleMatch rm , inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt , inl_act = cvtPhases phases dflt
, inl_sat = Nothing } , inl_sat = Nothing }
; returnJustL $ Hs.SigD $ InlineSig nm' ip } ; returnJustL $ Hs.SigD $ InlineSig noExt nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases) cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
...@@ -669,12 +670,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases) ...@@ -669,12 +670,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike , inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt , inl_act = cvtPhases phases dflt
, inl_sat = Nothing } , inl_sat = Nothing }
; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } ; returnJustL $ Hs.SigD $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
cvtPragmaD (SpecialiseInstP ty) cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty = do { ty' <- cvtType ty
; returnJustL $ Hs.SigD $ ; returnJustL $ Hs.SigD $
SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
cvtPragmaD (RuleP nm bndrs lhs rhs phases) cvtPragmaD (RuleP nm bndrs lhs rhs phases)
= do { let nm' = mkFastString nm = do { let nm' = mkFastString nm
...@@ -711,7 +712,7 @@ cvtPragmaD (CompleteP cls mty) ...@@ -711,7 +712,7 @@ cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls = do { cls' <- noLoc <$> mapM cNameL cls
; mty' <- traverse tconNameL mty ; mty' <- traverse tconNameL mty
; returnJustL $ Hs.SigD ; returnJustL $ Hs.SigD
$ CompleteMatchSig NoSourceText cls' mty' } $ CompleteMatchSig noExt NoSourceText cls' mty' }
dfltActivation :: TH.Inline -> Activation dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive dfltActivation TH.NoInline = NeverActive
...@@ -747,13 +748,13 @@ cvtRuleBndr (TypedRuleVar n ty) ...@@ -747,13 +748,13 @@ cvtRuleBndr (TypedRuleVar n ty)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc ds cvtLocalDecs doc ds
| null ds | null ds
= return EmptyLocalBinds = return (EmptyLocalBinds noExt)
| otherwise | otherwise
= do { ds' <- cvtDecs ds = do { ds' <- cvtDecs ds
; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs ; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; 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 cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
......
This diff is collapsed.
...@@ -132,6 +132,7 @@ type LHsDecl id = Located (HsDecl id) ...@@ -132,6 +132,7 @@ type LHsDecl id = Located (HsDecl id)
-- | A Haskell Declaration -- | A Haskell Declaration
data HsDecl id data HsDecl id
-- AZ:TODO:TTG HsDecl
= TyClD (TyClDecl id) -- ^ Type or Class Declaration = TyClD (TyClDecl id) -- ^ Type or Class Declaration
| InstD (InstDecl id) -- ^ Instance declaration | InstD (InstDecl id) -- ^ Instance declaration
| DerivD (DerivDecl id) -- ^ Deriving declaration | DerivD (DerivDecl id) -- ^ Deriving declaration
...@@ -147,7 +148,6 @@ data HsDecl id ...@@ -147,7 +148,6 @@ data HsDecl id
-- (Includes quasi-quotes) -- (Includes quasi-quotes)
| DocD (DocDecl) -- ^ Documentation comment declaration | DocD (DocDecl) -- ^ Documentation comment declaration
| RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration
deriving instance (DataIdLR id id) => Data (HsDecl id)
-- NB: all top-level fixity decls are contained EITHER -- NB: all top-level fixity decls are contained EITHER
...@@ -168,6 +168,7 @@ deriving instance (DataIdLR id id) => Data (HsDecl id) ...@@ -168,6 +168,7 @@ deriving instance (DataIdLR id id) => Data (HsDecl id)
-- A 'HsDecl' is categorised into a 'HsGroup' before being -- A 'HsDecl' is categorised into a 'HsGroup' before being
-- fed to the renamer. -- fed to the renamer.
data HsGroup id data HsGroup id
-- AZ:TODO:TTG HsGroup
= HsGroup { = HsGroup {
hs_valds :: HsValBinds id, hs_valds :: HsValBinds id,
hs_splcds :: [LSpliceDecl id], hs_splcds :: [LSpliceDecl id],
...@@ -193,7 +194,6 @@ data HsGroup id ...@@ -193,7 +194,6 @@ data HsGroup id