X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=e080bee8cf70b70482502fe2d373b0f89e627240;hp=f8afd262fe5b4a5585b5d262e5428ec3fd09c7da;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index f8afd26..e080bee 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] -- @@ -245,6 +246,13 @@ 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) + +getTypeSigNames :: HsValBinds a -> NameSet +-- Get the names that have a user type sig +getTypeSigNames (ValBindsIn {}) + = panic "getTypeSigNames" +getTypeSigNames (ValBindsOut _ sigs) + = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs] \end{code} What AbsBinds means @@ -277,18 +285,24 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL id ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss -ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs) +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, + fun_co_fn = wrap, fun_matches = matches, fun_tick = tick }) = pprTicks empty (case tick of Nothing -> empty Just t -> text "-- tick id = " <> ppr t) + $$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ 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), brackets (interpp'SP dictvars), @@ -297,10 +311,12 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars, nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports] -- Print type signatures $$ pprLHsBinds val_binds ) + $$ + ifPprDebug (ppr ev_binds) 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} @@ -341,7 +357,7 @@ data IPBind id instance (OutputableBndr id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ppr ds + $$ ifPprDebug (ppr ds) instance (OutputableBndr id) => Outputable (IPBind id) where ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) @@ -432,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 @@ -521,17 +537,28 @@ instance Outputable HsWrapper where pprHsWrapper :: SDoc -> HsWrapper -> SDoc -- In debug mode, print the wrapper -- otherwise just print what's inside -pprHsWrapper it wrap - = getPprStyle (\ s -> if debugStyle s then (help it wrap) else it) +pprHsWrapper doc wrap + = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc) where - help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpCast co) = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)] - help it (WpEvApp id) = sep [it, nest 2 (ppr id)] - help it (WpTyApp ty) = sep [it, ptext (sLit "@") <+> pprParendType ty] - help it (WpEvLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it] - help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it] - help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it] + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + 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)] + 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] + help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + + pp_bndr v = pprBndr LambdaBind v <> dot + + add_parens, no_parens :: SDoc -> Bool -> SDoc + add_parens d True = parens d + add_parens d False = d + no_parens d _ = d instance Outputable TcEvBinds where ppr (TcEvBinds v) = ppr v @@ -548,8 +575,7 @@ instance Outputable EvTerm where ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co ppr (EvCoercion 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} %************************************************************************ @@ -595,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) @@ -610,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) @@ -750,14 +779,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}