X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=1174278c2c843035db0f4314c1a10d51877b226f;hb=5819de0c5d78effa16e4c59987268eadb96b8d1d;hp=83dbd8b1352f03f387adabe272147c21a0a975e6;hpb=4a1b418e39175d1ee3482a309eb691ce29dc3199;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 83dbd8b..1174278 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -14,9 +14,9 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), - HsIdInfo(..), pprHsIdInfo, - - eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo, + HsIdInfo(..), pprHsIdInfo, + + eq_ufExpr, eq_ufBinders, pprUfExpr, toUfExpr, toUfBndr, ufBinderName ) where @@ -33,13 +33,12 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, -- others: import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) import Var ( varType, isId ) -import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo ) -import Name ( Name, NamedThing(..), getName, toRdrName ) +import IdInfo ( InlinePragInfo ) +import Name ( Name, NamedThing(..), eqNameByOcc ) import RdrName ( RdrName, rdrNameOcc ) -import OccName ( isTvOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) -import Demand ( StrictnessInfo ) +import NewDemand ( StrictSig, pprIfaceStrictSig ) import Literal ( Literal, maybeLitLit ) import ForeignCall ( ForeignCall ) import DataCon ( dataConTyCon, dataConSourceArity ) @@ -48,8 +47,9 @@ import Type ( Kind, eqKind ) import BasicTypes ( Arity ) import FiniteMap ( lookupFM ) import CostCentre -import Util ( eqListBy ) +import Util ( eqListBy, lengthIs ) import Outputable +import FastString \end{code} %************************************************************************ @@ -62,14 +62,14 @@ import Outputable 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 @@ -81,9 +81,9 @@ 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) @@ -144,7 +144,7 @@ toUfCon (LitAlt l) = case maybeLitLit l of 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)) @@ -159,7 +159,7 @@ toUfApp (Var v) as -> UfTuple (mk_hs_tup_con tc dc) tup_args where val_args = dropWhile isTypeArg as - saturated = length val_args == idArity v + saturated = val_args `lengthIs` idArity v tup_args = map toUfExpr val_args tc = dataConTyCon dc ; @@ -185,7 +185,7 @@ toUfVar v = case isFCallId_maybe v of %************************************************************************ \begin{code} -instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where +instance OutputableBndr name => Outputable (UfExpr name) where ppr e = pprUfExpr noParens e @@ -199,7 +199,7 @@ instance NamedThing RdrName where 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) @@ -209,7 +209,7 @@ pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHs 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) @@ -220,17 +220,13 @@ pprUfExpr add_par (UfCase scrut bndr alts) 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) @@ -266,6 +262,10 @@ instance Outputable name => Outputable (UfConAlt name) where 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} @@ -314,9 +314,10 @@ eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool -- 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 n2 + where + check n1 = eqNameByOcc (getName n1) (getName n2) ----------------- eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool @@ -373,27 +374,25 @@ eq_ufConAlt 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("##-}") data HsIdInfo name = HsArity Arity - | HsStrictness StrictnessInfo + | HsStrictness StrictSig | HsUnfold InlinePragInfo (UfExpr name) | HsNoCafRefs - | HsCprInfo | 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. -ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf) +ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf) ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity -ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str +ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str ppr_hs_info HsNoCafRefs = ptext SLIT("__C") -ppr_hs_info HsCprInfo = ptext SLIT("__M") ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a \end{code}