#include "HsVersions.h"
import IfaceType
-
+import CoreSyn( DFunArg, dfunArgExprs )
+import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
data IfaceIdDetails
= IfVanillaId
| IfRecSelId IfaceTyCon Bool
- | IfDFunId
+ | IfDFunId Int -- Number of silent args
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
| IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
-- another module.
- | IfDFunUnfold [IfaceExpr]
+ | IfDFunUnfold [DFunArg IfaceExpr]
--------------------------------
data IfaceExpr
= IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
- | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
+ | IfaceCo IfaceType -- We re-use IfaceType for coercions
+ | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as)
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
-pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
- = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+ = add_par (sep [ptext (sLit "case")
<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
pprIfaceExpr noParens rhs <+> char '}'])
-pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
- = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+ = add_par (sep [ptext (sLit "case")
<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{',
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
ppr IfVanillaId = empty
ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
<+> if b then ptext (sLit "<naughty>") else empty
- ppr IfDFunId = ptext (sLit "DFunId")
+ ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns)
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr
<+> parens (ptext (sLit "arity") <+> int a)
ppr (IfDFunUnfold ns) = ptext (sLit "DFun:")
- <+> brackets (pprWithCommas pprParendIfaceExpr ns)
-
+ <+> brackets (pprWithCommas ppr ns)
-- -----------------------------------------------------------------------------
-- Finding the Names in IfaceSyn
freeNamesIfType (IfaceForAllTy tv t) =
freeNamesIfTvBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) =
+ freeNamesIfCo tc &&& fnList freeNamesIfType ts
freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
-- Remember IfaceLetBndr is used only for *nested* bindings
--- The cut-down IdInfo never contains any Names, but the type may!
-freeNamesIfLetBndr (IfLetBndr _name ty _info) = freeNamesIfType ty
+-- The IdInfo can contain an unfolding (in the case of
+-- local INLINE pragmas), so look there too
+freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
+ &&& freeNamesIfIdInfo info
freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
-freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs
+freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co) = freeNamesIfType co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co
freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r
-freeNamesIfExpr (IfaceCase s _ ty alts)
+freeNamesIfExpr (IfaceCase s _ alts)
= freeNamesIfExpr s
&&& fnList fn_alt alts &&& fn_cons alts
- &&& freeNamesIfType ty
where
fn_alt (_con,_bs,r) = freeNamesIfExpr r
freeNamesIfExpr _ = emptyNameSet
-
freeNamesIfTc :: IfaceTyCon -> NameSet
freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfTc _ = emptyNameSet
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
freeNamesIfRule :: IfaceRule -> NameSet
freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
, ifRuleArgs = es, ifRuleRhs = rhs })