X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=1a1e935c4850d9510abc26cc57e3423da61c03b2;hb=cd54b707b0d77a3c62ee9f57b82dae98727f1c34;hp=7b4c17cb671bc31b96abcbd63f7c9b5ef5ca4a62;hpb=04d927e7ed15e20b264c6a3531391776def9cab5;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 7b4c17c..1a1e935 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -155,6 +155,7 @@ data HsBindLR idL idR abs_ev_binds :: TcEvBinds, -- Evidence bindings abs_binds :: LHsBinds idL -- Typechecked user bindings } + deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -299,8 +300,8 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, $$ pprFunBind (unLoc fun) inf matches $$ ifPprDebug (ppr wrap) -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars - , abs_exports = exports, abs_binds = val_binds +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) = sep [ptext (sLit "AbsBinds"), brackets (interpp'SP tyvars), @@ -315,7 +316,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars where ppr_exp (tvs, gbl, lcl, prags) = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl, - nest 2 (pprTcSpecPrags gbl prags)] + nest 2 (pprTcSpecPrags prags)] \end{code} @@ -356,7 +357,7 @@ data IPBind id instance (OutputableBndr id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ifPprDebug (ppr ds) + $$ ifPprDebug (ppr ds) instance (OutputableBndr id) => Outputable (IPBind id) where ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) @@ -447,7 +448,7 @@ data EvTerm | EvCast EvVar Coercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvVar] | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no @@ -456,7 +457,7 @@ data EvTerm deriving( Data, Typeable) evVarTerm :: EvVar -> EvTerm -evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v) +evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v) | otherwise = EvId v \end{code} @@ -545,7 +546,7 @@ pprHsWrapper doc wrap help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") - <+> pprParendType co)] + <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] @@ -571,11 +572,10 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co - ppr (EvCoercion co) = ppr co + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys - , ppr ts ] + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} %************************************************************************ @@ -621,10 +621,10 @@ data Sig name -- Signatures and pragmas -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE - -- A specialisation pragma for instance declarations only - -- {-# SPECIALISE instance Eq [Int] #-} - | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the - -- current instance decl + -- A specialisation pragma for instance declarations only + -- {-# SPECIALISE instance Eq [Int] #-} + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the + -- current instance decl deriving (Data, Typeable) @@ -636,11 +636,14 @@ data FixitySig name = FixitySig (Located name) Fixity data TcSpecPrags = IsDefaultMethod -- Super-specialised: a default method should -- be macro-expanded at every call site - | SpecPrags [Located TcSpecPrag] + | SpecPrags [LTcSpecPrag] deriving (Data, Typeable) +type LTcSpecPrag = Located TcSpecPrag + data TcSpecPrag = SpecPrag + Id -- The Id to be specialised HsWrapper -- An wrapper, that specialises the polymorphic function InlinePragma -- Inlining spec for the specialised function deriving (Data, Typeable) @@ -676,16 +679,12 @@ okInstDclSig (TypeSig _ _) = False okInstDclSig (FixSig _) = False okInstDclSig _ = True -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns - sigName :: LSig name -> Maybe name +-- Used only in Haddock sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> Maybe name +-- Used only in Haddock sigNameNoLoc (TypeSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n) @@ -776,14 +775,11 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl -pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc -pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "") -pprTcSpecPrags gbl (SpecPrags ps) = vcat (map (pprSpecPrag gbl) ps) - -pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc -pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "")) inl +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = ptext (sLit "") +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where - ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p + ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "")) inl \end{code}