UfBinding(..), UfConAlt(..),
HsIdInfo(..), pprHsIdInfo,
- eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
+ eq_ufExpr, eq_ufBinders, pprUfExpr,
toUfExpr, toUfBndr, ufBinderName
) where
)
-- others:
-import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
+import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe )
import Var ( varType, isId )
import IdInfo ( InlinePragInfo )
-import Name ( Name, NamedThing(..), toRdrName )
+import Name ( Name, NamedThing(..), eqNameByOcc )
import RdrName ( RdrName, rdrNameOcc )
-import OccName ( isTvOcc )
import CoreSyn
import CostCentre ( pprCostCentreCore )
import NewDemand ( StrictSig, pprIfaceStrictSig )
import CostCentre
import Util ( eqListBy, lengthIs )
import Outputable
+import FastString
\end{code}
%************************************************************************
data UfExpr name
= UfVar name
| UfType (HsType name)
- | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted
+ | UfTuple HsTupCon [UfExpr name] -- Type arguments omitted
| 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
- | UfLitLit FAST_STRING (HsType name)
+ | UfLitLit FastString (HsType name)
| UfFCall ForeignCall (HsType name)
data UfNote name = UfSCC CostCentre
| UfCoerce (HsType name)
| UfInlineCall
| UfInlineMe
+ | UfCoreNote String
type UfAlt name = (UfConAlt name, [name], UfExpr name)
data UfConAlt name = UfDefault
| UfDataAlt name
- | UfTupleAlt (HsTupCon name)
+ | UfTupleAlt HsTupCon
| UfLitAlt Literal
- | UfLitLitAlt FAST_STRING (HsType name)
+ | UfLitLitAlt FastString (HsType name)
data UfBinding name
= UfNonRec (UfBinder name)
toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
toUfNote InlineCall = UfInlineCall
toUfNote InlineMe = UfInlineMe
+toUfNote (CoreNote s) = UfCoreNote s
---------------------
toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
toUfCon DEFAULT = UfDefault
---------------------
-mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc)
+mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc)
---------------------
toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
---------------------
toUfApp (App f a) as = toUfApp f (a:as)
toUfApp (Var v) as
- = case isDataConId_maybe v of
+ = case isDataConWorkId_maybe v of
-- We convert the *worker* for tuples into UfTuples
Just dc | isTupleTyCon tc && saturated
-> UfTuple (mk_hs_tup_con tc dc) tup_args
%************************************************************************
\begin{code}
-instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where
+instance OutputableBndr name => Outputable (UfExpr name) where
ppr e = pprUfExpr noParens e
noParens :: SDoc -> SDoc
noParens pp = pp
-pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc
+pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
-pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
+pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs)
<+> 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
- pp_alt (c, bs, rhs) = ppr c <+> hsep (map pp_bndr bs) <+> ppr_rhs rhs
+ pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs
ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
- -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type
- pp_bndr v | isTvOcc (getOccName v) = char '@' <+> ppr v
- | otherwise = ppr v
-
pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
= add_par (hsep [ptext SLIT("let"),
- braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
+ braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs),
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 (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
instance Outputable name => Outputable (UfConAlt name) where
ppr UfDefault = text "__DEFAULT"
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
\end{code}
-- Compare *Rdr* names. A real hack to avoid gratuitous
-- differences when comparing interface files
eq_ufVar env n1 n2 = case lookupFM env n1 of
- Just n1 -> toRdrName n1 == toRdrName n2
- Nothing -> toRdrName n1 == toRdrName n2
-
+ Just n1 -> check n1
+ Nothing -> check n1
+ where
+ check n1 = eqNameByOcc (getName n1) (getName n2)
-----------------
eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
eq_ufNote UfInlineCall UfInlineCall = True
eq_ufNote UfInlineMe UfInlineMe = True
+ eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2
eq_ufNote _ _ = False
eq_ufExpr env _ _ = False
%************************************************************************
\begin{code}
-pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc
+pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc
pprHsIdInfo [] = empty
pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
projects / ghc-hetmet.git / blobdiff