module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
- HsIdInfo(..), pprHsIdInfo,
-
- eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
+ HsIdInfo(..), pprHsIdInfo,
+
+ eq_ufExpr, eq_ufBinders, pprUfExpr,
-- friends:
import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
HsTupCon(..), EqHsEnv, hsTupParens,
-- friends:
import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
HsTupCon(..), EqHsEnv, hsTupParens,
-import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
+import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe )
-import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo )
-import Name ( Name, NamedThing(..), getName, toRdrName )
+import IdInfo ( InlinePragInfo )
+import Name ( Name, NamedThing(..), eqNameByOcc )
import Literal ( Literal, maybeLitLit )
import ForeignCall ( ForeignCall )
import DataCon ( dataConTyCon, dataConSourceArity )
import Literal ( Literal, maybeLitLit )
import ForeignCall ( ForeignCall )
import DataCon ( dataConTyCon, dataConSourceArity )
| UfLam (UfBinder name) (UfExpr name)
| UfApp (UfExpr name) (UfExpr name)
| UfCase (UfExpr name) name [UfAlt name]
| UfLet (UfBinding name) (UfExpr name)
| UfNote (UfNote name) (UfExpr name)
| UfLit Literal
| UfLam (UfBinder name) (UfExpr name)
| UfApp (UfExpr name) (UfExpr name)
| UfCase (UfExpr name) name [UfAlt name]
| UfLet (UfBinding name) (UfExpr name)
| UfNote (UfNote name) (UfExpr name)
| UfLit Literal
type UfAlt name = (UfConAlt name, [name], UfExpr name)
data UfConAlt name = UfDefault
| UfDataAlt name
type UfAlt name = (UfConAlt name, [name], UfExpr name)
data UfConAlt name = UfDefault
| UfDataAlt name
toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
toUfNote InlineCall = UfInlineCall
toUfNote InlineMe = UfInlineMe
toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
toUfNote InlineCall = UfInlineCall
toUfNote InlineMe = UfInlineMe
-- We convert the *worker* for tuples into UfTuples
Just dc | isTupleTyCon tc && saturated
-> UfTuple (mk_hs_tup_con tc dc) tup_args
where
val_args = dropWhile isTypeArg as
-- We convert the *worker* for tuples into UfTuples
Just dc | isTupleTyCon tc && saturated
-> UfTuple (mk_hs_tup_con tc dc) tup_args
where
val_args = dropWhile isTypeArg as
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
<+> ptext SLIT("->") <+> pprUfExpr noParens body)
where (bndrs,body) = collectUfBndrs e
pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
<+> ptext SLIT("->") <+> pprUfExpr noParens body)
where (bndrs,body) = collectUfBndrs e
pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
braces (hsep (map pp_alt alts))])
where
pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
braces (hsep (map pp_alt alts))])
where
pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
= add_par (hsep [ptext SLIT("let"),
pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
= add_par (hsep [ptext SLIT("let"),
ptext SLIT("in"), pprUfExpr noParens body])
pprUfExpr add_par (UfLet (UfRec pairs) body)
ptext SLIT("in"), pprUfExpr noParens body])
pprUfExpr add_par (UfLet (UfRec pairs) body)
ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
ppr UfInlineCall = ptext SLIT("__inline_call")
ppr UfInlineMe = ptext SLIT("__inline_me")
ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
ppr UfInlineCall = ptext SLIT("__inline_call")
ppr UfInlineMe = ptext SLIT("__inline_me")
instance Outputable name => Outputable (UfBinder name) where
ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
instance Outputable name => Outputable (UfBinder name) where
ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
+
+instance OutputableBndr name => OutputableBndr (UfBinder name) where
+ pprBndr _ (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
+ pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
-- Compare *Rdr* names. A real hack to avoid gratuitous
-- differences when comparing interface files
eq_ufVar env n1 n2 = case lookupFM env n1 of
-- Compare *Rdr* names. A real hack to avoid gratuitous
-- differences when comparing interface files
eq_ufVar env n1 n2 = case lookupFM env n1 of
eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
eq_ufNote UfInlineCall UfInlineCall = True
eq_ufNote UfInlineMe UfInlineMe = True
eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
eq_ufNote UfInlineCall UfInlineCall = True
eq_ufNote UfInlineMe UfInlineMe = True
| HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo
-- for why we want arity here.
deriving( Eq )
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
| HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo
-- for why we want arity here.
deriving( Eq )
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.