diff options
Diffstat (limited to 'compiler/hsSyn/HsBinds.hs')
| -rw-r--r-- | compiler/hsSyn/HsBinds.hs | 518 |
1 files changed, 308 insertions, 210 deletions
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index f08a6af700..98f503b0d9 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -14,9 +14,12 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} module HsBinds where +import GhcPrelude + import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, GRHSs, pprPatBind ) @@ -54,7 +57,7 @@ Global bindings (where clauses) -} -- During renaming, we need bindings where the left-hand sides --- have been renamed but the the right-hand sides have not. +-- have been renamed but the right-hand sides have not. -- the ...LR datatypes are parametrized by two id types, -- one for the left and one for the right. -- Other than during renaming, these will be the same. @@ -70,23 +73,34 @@ type LHsLocalBinds id = Located (HsLocalBinds id) -- Bindings in a 'let' expression -- or a 'where' clause data HsLocalBindsLR idL idR - = HsValBinds (HsValBindsLR idL idR) + = HsValBinds + (XHsValBinds idL idR) + (HsValBindsLR idL idR) -- ^ Haskell Value Bindings -- There should be no pattern synonyms in the HsValBindsLR -- These are *local* (not top level) bindings - -- The parser accepts them, however, leaving the the + -- The parser accepts them, however, leaving the -- renamer to report them - | HsIPBinds (HsIPBinds idR) + | HsIPBinds + (XHsIPBinds idL idR) + (HsIPBinds idR) -- ^ Haskell Implicit Parameter Bindings - | EmptyLocalBinds + | EmptyLocalBinds (XEmptyLocalBinds idL idR) -- ^ Empty Local Bindings + | XHsLocalBindsLR + (XXHsLocalBindsLR idL idR) + +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt + type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id @@ -101,18 +115,31 @@ data HsValBindsLR idL idR -- Before renaming RHS; idR is always RdrName -- Not dependency analysed -- Recursive by default - ValBindsIn + ValBinds + (XValBinds idL idR) (LHsBindsLR idL idR) [LSig idR] -- | Value Bindings Out -- -- After renaming RHS; idR can be Name or Id Dependency analysed, -- later bindings in the list may depend on earlier ones. - | ValBindsOut - [(RecFlag, LHsBinds idL)] - [LSig GhcRn] -- AZ: how to do this? + | XValBindsLR + (XXValBindsLR idL idR) + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +-- TODO: make this the only type for ValBinds +data NHsValBindsLR idL + = NValBinds + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] -deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR) +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XXValBindsLR (GhcPass pL) (GhcPass pR) + = NHsValBindsLR (GhcPass pL) + +-- --------------------------------------------------------------------- -- | Located Haskell Binding type LHsBind id = LHsBindLR id id @@ -129,9 +156,8 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) -- | Located Haskell Binding with separate Left and Right identifier types type LHsBindLR idL idR = Located (HsBindLR idL idR) -{- Note [Varieties of binding pattern matches] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - +{- Note [FunBind vs PatBind] + ~~~~~~~~~~~~~~~~~~~~~~~~~ The distinction between FunBind and PatBind is a bit subtle. FunBind covers patterns which resemble function bindings and simple variable bindings. @@ -142,12 +168,17 @@ patterns which resemble function bindings and simple variable bindings. x `f` y = e -- FunRhs has Infix The actual patterns and RHSs of a FunBind are encoding in fun_matches. -The m_ctxt field of Match will be FunRhs and carries two bits of information -about the match, +The m_ctxt field of each Match in fun_matches will be FunRhs and carries +two bits of information about the match, - * the mc_strictness field describes whether the match is decorated with a bang - (e.g. `!x = e`) - * the mc_fixity field describes the fixity of the function binder + * The mc_fixity field on each Match describes the fixity of the + function binder in that match. E.g. this is legal: + f True False = e1 + True `f` True = e2 + + * The mc_strictness field is used /only/ for nullary FunBinds: ones + with one Match, which has no pats. For these, it describes whether + the match is decorated with a bang (e.g. `!x = e`). By contrast, PatBind represents data constructor patterns, as well as a few other interesting cases. Namely, @@ -175,7 +206,7 @@ data HsBindLR idL idR -- @(f :: a -> a) = ... @ -- -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their - -- 'MatchContext'. See Note [Varieties of binding pattern matches] for + -- 'MatchContext'. See Note [FunBind vs PatBind] for -- details about the relationship between FunBind and PatBind. -- -- 'ApiAnnotation.AnnKeywordId's @@ -188,6 +219,11 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation FunBind { + fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains + -- the locally-bound + -- free variables of this defn. + -- See Note [Bind free vars] + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload @@ -206,12 +242,6 @@ data HsBindLR idL idR -- type Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. - bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains - -- the locally-bound - -- free variables of this defn. - -- See Note [Bind free vars] - - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any } @@ -219,7 +249,7 @@ data HsBindLR idL idR -- -- The pattern is never a simple variable; -- That case is done by FunBind. - -- See Note [Varieties of binding pattern matches] for details about the + -- See Note [FunBind vs PatBind] for details about the -- relationship between FunBind and PatBind. -- @@ -229,10 +259,9 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation | PatBind { + pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] pat_lhs :: LPat idL, pat_rhs :: GRHSs idR (LHsExpr idR), - pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs - bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars] pat_ticks :: ([Tickish Id], [[Tickish Id]]) -- ^ Ticks to put on the rhs, if any, and ticks to put on -- the bound variables. @@ -243,6 +272,7 @@ data HsBindLR idL idR -- Dictionary binding and suchlike. -- All VarBinds are introduced by the type checker | VarBind { + var_ext :: XVarBind idL idR, var_id :: IdP idL, var_rhs :: LHsExpr idR, -- ^ Located only for consistency var_inline :: Bool -- ^ True <=> inline this binding regardless @@ -251,6 +281,7 @@ data HsBindLR idL idR -- | Abstraction Bindings | AbsBinds { -- Binds abstraction; TRANSLATION + abs_ext :: XAbsBinds idL idR, abs_tvs :: [TyVar], abs_ev_vars :: [EvVar], -- ^ Includes equality constraints @@ -265,26 +296,15 @@ data HsBindLR idL idR abs_ev_binds :: [TcEvBinds], -- | Typechecked user bindings - abs_binds :: LHsBinds idL - } + abs_binds :: LHsBinds idL, - -- | Abstraction Bindings Signature - | AbsBindsSig { -- Simpler form of AbsBinds, used with a type sig - -- in tcPolyCheck. Produces simpler desugaring and - -- is necessary to avoid #11405, comment:3. - abs_tvs :: [TyVar], - abs_ev_vars :: [EvVar], - - abs_sig_export :: IdP idL, -- like abe_poly - abs_sig_prags :: TcSpecPrags, - - abs_sig_ev_bind :: TcEvBinds, -- no list needed here - abs_sig_bind :: LHsBind idL -- always only one, and it's always a - -- FunBind + abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] } -- | Patterns Synonym Binding - | PatSynBind (PatSynBind idL idR) + | PatSynBind + (XPatSynBind idL idR) + (PatSynBind idL idR) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', -- 'ApiAnnotation.AnnWhere' @@ -292,7 +312,26 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR) + | XHsBindsLR (XXHsBindsLR idL idR) + +data NPatBindTc = NPatBindTc { + pat_fvs :: NameSet, -- ^ Free variables + pat_rhs_ty :: Type -- ^ Type of the GRHSs + } deriving Data + +type instance XFunBind (GhcPass pL) GhcPs = NoExt +type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables + +type instance XPatBind GhcPs (GhcPass pR) = NoExt +type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables +type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc + +type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -308,13 +347,18 @@ deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR) -- | Abtraction Bindings Export data ABExport p - = ABE { abe_poly :: IdP p -- ^ Any INLINE pragmas is attached to this Id + = ABE { abe_ext :: XABE p + , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id , abe_mono :: IdP p , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas - } -deriving instance (DataId p) => Data (ABExport p) + } + | XABExport (XXABExport p) + +type instance XABE (GhcPass p) = NoExt +type instance XXABExport (GhcPass p) = NoExt + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' @@ -325,14 +369,21 @@ deriving instance (DataId p) => Data (ABExport p) -- | Pattern Synonym binding data PatSynBind idL idR - = PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym - psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] + = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. + -- See Note [Bind free vars] + psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym psb_args :: HsPatSynDetails (Located (IdP idR)), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality - } -deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) + } + | XPatSynBind (XXPatSynBind idL idR) + +type instance XPSB (GhcPass idL) GhcPs = NoExt +type instance XPSB (GhcPass idL) GhcRn = NameSet +type instance XPSB (GhcPass idL) GhcTc = NameSet + +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt {- Note [AbsBinds] @@ -477,6 +528,53 @@ bindings only when lacks a user type signature * The group forms a strongly connected component + +Note [The abs_sig field of AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The abs_sig field supports a couple of special cases for bindings. +Consider + + x :: Num a => (# a, a #) + x = (# 3, 4 #) + +The general desugaring for AbsBinds would give + + x = /\a. \ ($dNum :: Num a) -> + letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in + xm + +But that has an illegal let-binding for an unboxed tuple. In this +case we'd prefer to generate the (more direct) + + x = /\ a. \ ($dNum :: Num a) -> + (# fromInteger $dNum 3, fromInteger $dNum 4 #) + +A similar thing happens with representation-polymorphic defns +(Trac #11405): + + undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + undef = error "undef" + +Again, the vanilla desugaring gives a local let-binding for a +representation-polymorphic (undefm :: a), which is illegal. But +again we can desugar without a let: + + undef = /\ a. \ (d:HasCallStack) -> error a d "undef" + +The abs_sig field supports this direct desugaring, with no local +let-bining. When abs_sig = True + + * the abs_binds is single FunBind + + * the abs_exports is a singleton + + * we have a complete type sig for binder + and hence the abs_binds is non-recursive + (it binds the mono_id but refers to the poly_id + +These properties are exploited in DsBinds.dsAbsBinds to +generate code without a let-binding. + Note [ABExport wrapper] ~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -520,20 +618,21 @@ Specifically, it's just an error thunk -} -instance (SourceTextX idL, SourceTextX idR, +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsLocalBindsLR idL idR) where - ppr (HsValBinds bs) = ppr bs - ppr (HsIPBinds bs) = ppr bs - ppr EmptyLocalBinds = empty + ppr (HsValBinds _ bs) = ppr bs + ppr (HsIPBinds _ bs) = ppr bs + ppr (EmptyLocalBinds _) = empty + ppr (XHsLocalBindsLR x) = ppr x -instance (SourceTextX idL, SourceTextX idR, +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsValBindsLR idL idR) where - ppr (ValBindsIn binds sigs) + ppr (ValBinds _ binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) - ppr (ValBindsOut sccs sigs) + ppr (XValBindsLR (NValBinds sccs sigs)) = getPprStyle $ \ sty -> if debugStyle sty then -- Print with sccs showing vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) @@ -544,17 +643,16 @@ instance (SourceTextX idL, SourceTextX idR, pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => LHsBindsLR idL idR -> SDoc +pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR, - SourceTextX id2, OutputableBndrId id2) - => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] +pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + OutputableBndrId (GhcPass id2)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups -- and we don't want several groups of bindings each @@ -583,25 +681,33 @@ pprDeclList :: [SDoc] -> SDoc -- Braces with a space pprDeclList ds = pprDeeperList vcat ds ------------ -emptyLocalBinds :: HsLocalBindsLR a b -emptyLocalBinds = EmptyLocalBinds - -isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool -isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds -isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds -isEmptyLocalBinds EmptyLocalBinds = True +emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) +emptyLocalBinds = EmptyLocalBinds noExt + +-- AZ:These functions do not seem to be used at all? +isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool +isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds +isEmptyLocalBindsTc (EmptyLocalBinds _) = True +isEmptyLocalBindsTc (XHsLocalBindsLR _) = True + +isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds +isEmptyLocalBindsPR (EmptyLocalBinds _) = True +isEmptyLocalBindsPR (XHsLocalBindsLR _) = True eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool -eqEmptyLocalBinds EmptyLocalBinds = True -eqEmptyLocalBinds _ = False +eqEmptyLocalBinds (EmptyLocalBinds _) = True +eqEmptyLocalBinds _ = False -isEmptyValBinds :: HsValBindsLR a b -> Bool -isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs -isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs +isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs -emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b -emptyValBindsIn = ValBindsIn emptyBag [] -emptyValBindsOut = ValBindsOut [] [] +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) +emptyValBindsIn = ValBinds noExt emptyBag [] +emptyValBindsOut = XValBindsLR (NValBinds [] []) emptyLHsBinds :: LHsBindsLR idL idR emptyLHsBinds = emptyBag @@ -610,22 +716,23 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool isEmptyLHsBinds = isEmptyBag ------------ -plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a -plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) - = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) -plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) - = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) + = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) + (XValBindsLR (NValBinds ds2 sigs2)) + = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" -instance (SourceTextX idL, SourceTextX idR, +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => HsBindLR idL idR -> SDoc +ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss @@ -637,10 +744,10 @@ ppr_monobind (FunBind { fun_id = fun, fun_tick = ticks }) = pprTicks empty (if null ticks then empty else text "-- ticks = " <> ppr ticks) - $$ ifPprDebug (pprBndr LetBind (unLoc fun)) + $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches - $$ ifPprDebug (ppr wrap) -ppr_monobind (PatSynBind psb) = ppr psb + $$ whenPprDebug (ppr wrap) +ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) @@ -658,30 +765,17 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , text "Evidence:" <+> ppr ev_binds ] else pprLHsBinds val_binds -ppr_monobind (AbsBindsSig { abs_tvs = tyvars - , abs_ev_vars = dictvars - , abs_sig_export = poly_id - , abs_sig_ev_bind = ev_bind - , abs_sig_bind = bind }) - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags then - hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars) - <+> brackets (interpp'SP dictvars)) - 2 $ braces $ vcat - [ text "Exported type:" <+> pprBndr LetBind poly_id - , text "Bind:" <+> ppr bind - , text "Evidence:" <+> ppr ev_bind ] - else - ppr bind +ppr_monobind (XHsBindsLR x) = ppr x -instance (OutputableBndrId p) => Outputable (ABExport p) where +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] + ppr (XABExport x) = ppr x -instance (SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) +instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, + Outputable (XXPatSynBind idL idR)) => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) @@ -691,17 +785,17 @@ instance (SourceTextX idR, ppr_simple syntax = syntax <+> ppr pat ppr_details = case details of - InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] - PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs) - RecordPatSyn vs -> - pprPrefixOcc psyn - <> braces (sep (punctuate comma (map ppr vs))) + InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] + PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs) + RecCon vs -> pprPrefixOcc psyn + <> braces (sep (punctuate comma (map ppr vs))) ppr_rhs = case dir of Unidirectional -> ppr_simple (text "<-") ImplicitBidirectional -> ppr_simple equals ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ (nest 2 $ pprFunBind mg) + ppr (XPatSynBind x) = ppr x pprTicks :: SDoc -> SDoc -> SDoc -- Print stuff about ticks only when -dppr-debug is on, to avoid @@ -724,13 +818,27 @@ pprTicks pp_no_debug pp_when_debug -- | Haskell Implicit Parameter Bindings data HsIPBinds id = IPBinds + (XIPBinds id) [LIPBind id] - TcEvBinds -- Only in typechecker output; binds - -- uses of the implicit parameters -deriving instance (DataId id) => Data (HsIPBinds id) + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds (XXHsIPBinds id) + +type instance XIPBinds GhcPs = NoExt +type instance XIPBinds GhcRn = NoExt +type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters -isEmptyIPBinds :: HsIPBinds id -> Bool -isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds + +type instance XXHsIPBinds (GhcPass p) = NoExt + +isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool +isEmptyIPBindsPR (IPBinds _ is) = null is +isEmptyIPBindsPR (XHsIPBinds _) = True + +isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool +isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds +isEmptyIPBindsTc (XHsIPBinds _) = True -- | Located Implicit Parameter Binding type LIPBind id = Located (IPBind id) @@ -750,18 +858,27 @@ type LIPBind id = Located (IPBind id) -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id - = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id) -deriving instance (DataId name) => Data (IPBind name) - -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where - ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ifPprDebug (ppr ds) - -instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where - ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + = IPBind + (XCIPBind id) + (Either (Located HsIPName) (IdP id)) + (LHsExpr id) + | XIPBind (XXIPBind id) + +type instance XCIPBind (GhcPass p) = NoExt +type instance XXIPBind (GhcPass p) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsIPBinds p) where + ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) + $$ whenPprDebug (ppr ds) + ppr (XHsIPBinds x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where + ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip Right id -> pprBndr LetBind id + ppr (XIPBind x) = ppr x {- ************************************************************************ @@ -798,6 +915,7 @@ data Sig pass -- For details on above see note [Api annotations] in ApiAnnotation TypeSig + (XTypeSig pass) [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah (LHsSigWcType pass) -- RHS of the signature; can have wildcards @@ -810,7 +928,7 @@ data Sig pass -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig [Located (IdP pass)] (LHsSigType pass) + | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) -- P :: forall a b. Req => Prov => ty -- | A signature for a class method @@ -823,14 +941,14 @@ data Sig pass -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass) + | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type -- and IdDetails. Otherwise it's just like a type -- signature: there should be an accompanying binding - | IdSig Id + | IdSig (XIdSig pass) Id -- | An ordinary fixity declaration -- @@ -841,7 +959,7 @@ data Sig pass -- 'ApiAnnotation.AnnVal' -- For details on above see note [Api annotations] in ApiAnnotation - | FixSig (FixitySig pass) + | FixSig (XFixSig pass) (FixitySig pass) -- | An inline pragma -- @@ -854,7 +972,8 @@ data Sig pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (Located (IdP pass)) -- Function name + | InlineSig (XInlineSig pass) + (Located (IdP pass)) -- Function name InlinePragma -- Never defaultInlinePragma -- | A specialisation pragma @@ -869,7 +988,8 @@ data Sig pass -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located (IdP pass)) -- Specialise a function or datatype ... + | SpecSig (XSpecSig pass) + (Located (IdP pass)) -- Specialise a function or datatype ... [LHsSigType pass] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said @@ -886,7 +1006,7 @@ data Sig pass -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig SourceText (LHsSigType pass) + | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma @@ -898,7 +1018,8 @@ data Sig pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig SourceText (LBooleanFormula (Located (IdP pass))) + | MinimalSig (XMinimalSig pass) + SourceText (LBooleanFormula (Located (IdP pass))) -- Note [Pragma source text] in BasicTypes -- | A "set cost centre" pragma for declarations @@ -909,7 +1030,8 @@ data Sig pass -- -- > {-# SCC funName "cost_centre_name" #-} - | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes + | SCCFunSig (XSCCFunSig pass) + SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma @@ -919,18 +1041,34 @@ data Sig pass -- Used to inform the pattern match checker about additional -- complete matchings which, for example, arise from pattern -- synonym definitions. - | CompleteMatchSig SourceText + | CompleteMatchSig (XCompleteMatchSig pass) + SourceText (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) - -deriving instance (DataId pass) => Data (Sig pass) + | XSig (XXSig pass) + +type instance XTypeSig (GhcPass p) = NoExt +type instance XPatSynSig (GhcPass p) = NoExt +type instance XClassOpSig (GhcPass p) = NoExt +type instance XIdSig (GhcPass p) = NoExt +type instance XFixSig (GhcPass p) = NoExt +type instance XInlineSig (GhcPass p) = NoExt +type instance XSpecSig (GhcPass p) = NoExt +type instance XSpecInstSig (GhcPass p) = NoExt +type instance XMinimalSig (GhcPass p) = NoExt +type instance XSCCFunSig (GhcPass p) = NoExt +type instance XCompleteMatchSig (GhcPass p) = NoExt +type instance XXSig (GhcPass p) = NoExt -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) -- | Fixity Signature -data FixitySig pass = FixitySig [Located (IdP pass)] Fixity -deriving instance (DataId pass) => Data (FixitySig pass) +data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity + | XFixitySig (XXFixitySig pass) + +type instance XFixitySig (GhcPass p) = NoExt +type instance XXFixitySig (GhcPass p) = NoExt -- | Type checker Specialisation Pragmas -- @@ -950,7 +1088,7 @@ data TcSpecPrag Id HsWrapper InlinePragma - -- ^ The Id to be specialised, an wrapper that specialises the + -- ^ The Id to be specialised, a wrapper that specialises the -- polymorphic function, and inlining spec for the specialised function deriving Data @@ -1012,17 +1150,18 @@ isCompleteMatchSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = text "type signature" hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig is_deflt _ _) +hsSigDoc (ClassOpSig _ is_deflt _ _) | is_deflt = text "default type signature" | otherwise = text "class method signature" hsSigDoc (IdSig {}) = text "id signature" hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" -hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" +hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" hsSigDoc (FixSig {}) = text "fixity declaration" hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" hsSigDoc (SCCFunSig {}) = text "SCC pragma" hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig {}) = text "XSIG TTG extension" {- Check if signatures overlap; this is used when checking for duplicate @@ -1030,46 +1169,48 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (Sig pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where ppr sig = ppr_sig sig -ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc -ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (ClassOpSig is_deflt vars ty) +ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc +ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) -ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec })) +ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig _ fix_sig) = ppr fix_sig +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) (interpp'SP ty) inl) where pragmaSrc = case spec of - EmptyInlineSpec -> "{-# SPECIALISE" - _ -> "{-# SPECIALISE_INLINE" -ppr_sig (InlineSig var inl) + NoUserInline -> "{-# SPECIALISE" + _ -> "{-# SPECIALISE_INLINE" +ppr_sig (InlineSig _ var inl) = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig src ty) +ppr_sig (SpecInstSig _ src ty) = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig src bf) +ppr_sig (MinimalSig _ src bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) -ppr_sig (PatSynSig names sig_ty) +ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig src fn mlabel) +ppr_sig (SCCFunSig _ src fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) -ppr_sig (CompleteMatchSig src cs mty) +ppr_sig (CompleteMatchSig _ src cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr (unLoc cs)))) <+> opt_sig) where opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty +ppr_sig (XSig x) = ppr x -instance OutputableBndrId pass => Outputable (FixitySig pass) where - ppr (FixitySig names fixity) = sep [ppr fixity, pprops] +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FixitySig p) where + ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) + ppr (XFixitySig x) = ppr x pragBrackets :: SDoc -> SDoc pragBrackets doc = text "{-#" <+> doc <+> text "#-}" @@ -1112,12 +1253,7 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) -} -- | Haskell Pattern Synonym Details -data HsPatSynDetails a - = InfixPatSyn a a -- ^ Infix Pattern Synonym - | PrefixPatSyn [a] -- ^ Prefix Pattern Synonym - | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym - deriving Data - +type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg] -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field @@ -1174,46 +1310,8 @@ instance Traversable RecordPatSynField where <$> f visible <*> f hidden -instance Functor HsPatSynDetails where - fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right) - fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args) - fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args) - -instance Foldable HsPatSynDetails where - foldMap f (InfixPatSyn left right) = f left `mappend` f right - foldMap f (PrefixPatSyn args) = foldMap f args - foldMap f (RecordPatSyn args) = foldMap (foldMap f) args - - foldl1 f (InfixPatSyn left right) = left `f` right - foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args - foldl1 f (RecordPatSyn args) = - Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args) - - foldr1 f (InfixPatSyn left right) = left `f` right - foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args - foldr1 f (RecordPatSyn args) = - Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args) - - length (InfixPatSyn _ _) = 2 - length (PrefixPatSyn args) = Data.List.length args - length (RecordPatSyn args) = Data.List.length args - - null (InfixPatSyn _ _) = False - null (PrefixPatSyn args) = Data.List.null args - null (RecordPatSyn args) = Data.List.null args - - toList (InfixPatSyn left right) = [left, right] - toList (PrefixPatSyn args) = args - toList (RecordPatSyn args) = foldMap toList args - -instance Traversable HsPatSynDetails where - traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right - traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args - traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args - -- | Haskell Pattern Synonym Direction data HsPatSynDir id = Unidirectional | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) -deriving instance (DataId id) => Data (HsPatSynDir id) |