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]
--
= 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
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),
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}
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)
| 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
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
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}
%************************************************************************
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)
pp_inl | isDefaultInlinePragma inl = empty
| otherwise = ppr inl
-pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
-pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "<default method>")
-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 "<type>")) inl
+pprTcSpecPrags :: TcSpecPrags -> SDoc
+pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
+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 "<type>")) inl
\end{code}
projects / ghc-hetmet.git / blobdiff