module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
- HsIdInfo(..),
- IfaceSig(..),
+ HsIdInfo(..), pprHsIdInfo,
- eq_ufExpr, eq_ufBinders, pprUfExpr,
+ eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
- toUfExpr, toUfBndr
+ toUfExpr, toUfBndr, ufBinderName
) where
#include "HsVersions.h"
-- friends:
import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
- HsTupCon(..), hsTupParens,
+ HsTupCon(..), EqHsEnv, hsTupParens,
emptyEqHsEnv, extendEqHsEnv, eqListBy,
- eq_hsType, eq_hsVar, eq_hsVars
+ eq_hsType, eq_hsVars
)
-- others:
-import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
+import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
import Var ( varType, isId )
-import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo,
- pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
- )
-import RdrName ( RdrName )
-import Name ( Name, toRdrName )
+import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo )
+import Name ( Name, NamedThing(..), getName, toRdrName )
+import RdrName ( RdrName, rdrNameOcc )
+import OccName ( isTvOcc )
import CoreSyn
import CostCentre ( pprCostCentreCore )
-import PrimOp ( PrimOp(CCallOp) )
-import Demand ( Demand, StrictnessInfo )
+import Demand ( StrictnessInfo )
import Literal ( Literal, maybeLitLit )
-import PrimOp ( CCall, pprCCallOp )
-import DataCon ( dataConTyCon )
+import ForeignCall ( ForeignCall )
+import DataCon ( dataConTyCon, dataConSourceArity )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
-import Type ( Type, Kind )
-import CostCentre
-import SrcLoc ( SrcLoc )
+import Type ( Kind, eqKind )
import BasicTypes ( Arity )
+import FiniteMap ( lookupFM )
+import CostCentre
import Outputable
\end{code}
| UfNote (UfNote name) (UfExpr name)
| UfLit Literal
| UfLitLit FAST_STRING (HsType name)
- | UfCCall CCall (HsType name)
+ | UfFCall ForeignCall (HsType name)
data UfNote name = UfSCC CostCentre
| UfCoerce (HsType name)
data UfBinder name
= UfValBinder name (HsType name)
| UfTyBinder name Kind
+
+ufBinderName :: UfBinder name -> name
+ufBinderName (UfValBinder n _) = n
+ufBinderName (UfTyBinder n _) = n
\end{code}
%************************************************************************
\begin{code}
-toUfExpr :: CoreExpr -> UfExpr RdrName
+toUfExpr :: CoreExpr -> UfExpr Name
toUfExpr (Var v) = toUfVar v
toUfExpr (Lit l) = case maybeLitLit l of
Just (s,ty) -> UfLitLit s (toHsType ty)
toUfExpr (Type ty) = UfType (toHsType ty)
toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
toUfExpr (App f a) = toUfApp f [a]
-toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as)
+toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
---------------------
-toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r)
+toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
---------------------
-toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
- | otherwise = UfDataAlt (toRdrName dc)
+toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
+ | otherwise = UfDataAlt (getName dc)
where
tc = dataConTyCon dc
toUfCon DEFAULT = UfDefault
---------------------
-toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x))
- | otherwise = UfTyBinder (toRdrName x) (varType x)
+mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc)
+
+---------------------
+toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
+ | otherwise = UfTyBinder (getName x) (varType x)
---------------------
toUfApp (App f a) as = toUfApp f (a:as)
toUfApp (Var v) as
= case isDataConId_maybe v of
-- We convert the *worker* for tuples into UfTuples
- Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args
+ Just dc | isTupleTyCon tc && saturated
+ -> UfTuple (mk_hs_tup_con tc dc) tup_args
where
val_args = dropWhile isTypeArg as
saturated = length val_args == idArity v
mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
---------------------
-toUfVar v = case isPrimOpId_maybe v of
- -- Ccalls has special syntax
- Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
- other -> UfVar (toRdrName v)
+toUfVar v = case isFCallId_maybe v of
+ -- Foreign calls have special syntax
+ Just fcall -> UfFCall fcall (toHsType (idType v))
+ other -> UfVar (getName v)
\end{code}
%************************************************************************
\begin{code}
-instance Outputable name => Outputable (UfExpr name) where
+instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where
ppr e = pprUfExpr noParens e
+
+-- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
+-- Important because we want to pretty-print UfExprs, and we have to
+-- print an '@' before tyvar-binders in a case alternative.
+instance NamedThing RdrName where
+ getOccName n = rdrNameOcc n
+ getName n = pprPanic "instance NamedThing RdrName" (ppr n)
+
noParens :: SDoc -> SDoc
noParens pp = pp
-pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
+pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
pprUfExpr add_par (UfVar v) = ppr v
pprUfExpr add_par (UfLit l) = ppr l
-pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
-pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
+pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
+pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
-pprUfExpr add_par (UfLam b body) = add_par (hsep [char '\\', ppr b, ptext SLIT("->"), pprUfExpr noParens body])
-pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
+
+pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
+ <+> ptext SLIT("->") <+> pprUfExpr noParens body)
+ where (bndrs,body) = collectUfBndrs e
+pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
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 <+> interppSP bs <+> ppr_rhs rhs
+ pp_alt (c, bs, rhs) = ppr c <+> hsep (map pp_bndr 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),
pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
+pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg
+pprUfApp fun = pprUfExpr parens fun
+
+collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
+collectUfBndrs expr
+ = go [] expr
+ where
+ go bs (UfLam b e) = go (b:bs) e
+ go bs e = (reverse bs, e)
+
instance Outputable name => Outputable (UfNote name) where
ppr (UfSCC cc) = pprCostCentreCore cc
ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
instance Outputable name => Outputable (UfConAlt name) where
ppr UfDefault = text "__DEFAULT"
ppr (UfLitAlt l) = ppr l
- ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
+ ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
ppr (UfDataAlt d) = ppr d
instance Outputable name => Outputable (UfBinder name) where
%* *
%************************************************************************
+ ----------------------------------------
+ HACK ALERT
+ ----------------------------------------
+
+Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
+those. Reason: this is used when comparing ufoldings in interface files, and the
+uniques can differ. Converting to RdrNames makes it more like comparing the file
+contents directly. But this is bad: version numbers can change when only alpha-conversion
+has happened.
+
+ The hack shows up in eq_ufVar
+ There are corresponding getOccName calls in MkIface.diffDecls
+
+ ----------------------------------------
+ END OF HACK ALERT
+ ----------------------------------------
+
+
\begin{code}
-instance Ord name => Eq (UfExpr name) where
+instance (NamedThing name, Ord name) => Eq (UfExpr name) where
(==) a b = eq_ufExpr emptyEqHsEnv a b
-----------------
eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
= eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
- = k1==k2 && k (extendEqHsEnv env n1 n2)
+ = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2)
eq_ufBinder _ _ _ _ = False
-----------------
eq_ufBinders env _ _ _ = False
-----------------
-eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2
+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
+
+
+-----------------
+eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
+eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
-eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
+eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
%************************************************************************
%* *
-\subsection{Signatures in interface files}
-%* *
-%************************************************************************
-
-\begin{code}
-data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc
-
-instance Ord name => Eq (IfaceSig name) where
- (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
-
-instance (Outputable name) => Outputable (IfaceSig name) where
- ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Rules in interface files}
%* *
%************************************************************************
\begin{code}
+pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc
pprHsIdInfo [] = empty
-pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}")
+pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
data HsIdInfo name
- = HsArity ArityInfo
+ = HsArity Arity
| HsStrictness StrictnessInfo
| HsUnfold InlinePragInfo (UfExpr name)
- | HsUpdate UpdateInfo
| HsNoCafRefs
| HsCprInfo
- | HsWorker name -- Worker, if any
+ | 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.
-instance Outputable name => Outputable (HsIdInfo name) where
- ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf)
- ppr (HsArity arity) = ppArityInfo arity
- ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
- ppr HsNoCafRefs = ptext SLIT("__C")
- ppr HsCprInfo = ptext SLIT("__M")
- ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w
+ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo 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 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}
projects / ghc-hetmet.git / blobdiff