%
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module IfaceSyn (
module IfaceType, -- Re-export all this
import NewDemand
import Class
import UniqFM
+import UniqSet
import NameSet
import Name
import CostCentre
import BasicTypes
import Outputable
import FastString
+import Module
import Data.List
import Data.Maybe
| IfaceCast IfaceExpr IfaceCoercion
| IfaceLit Literal
| IfaceFCall ForeignCall IfaceType
+ | IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
| IfaceInlineMe
Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Occasionally we want to preserve IdInfo on nested let bindings The one
+Occasionally we want to preserve IdInfo on nested let bindings. The one
that came up was a NOINLINE pragma on a let-binding inside an INLINE
function. The user (Duncan Coutts) really wanted the NOINLINE control
to cross the separate compilation boundary.
-- Deeply revolting, because it has to predict what gets bound,
-- especially the question of whether there's a wrapper for a datacon
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
- ifSigs = sigs, ifATs = ats })
- = co_occs ++
- [tc_occ, dc_occ, dcww_occ] ++
- [op | IfaceClassOp op _ _ <- sigs] ++
- [ifName at | at <- ats ] ++
- [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
- where
- n_ctxt = length sc_ctxt
- n_sigs = length sigs
- tc_occ = mkClassTyConOcc cls_occ
- dc_occ = mkClassDataConOcc cls_occ
- co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
- | otherwise = []
- dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
- | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
- is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+-- N.B. the set of names returned here *must* match the set of
+-- TyThings returned by HscTypes.implicitTyThings, in the sense that
+-- TyThing.getOccName should define a bijection between the two lists.
+-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
+-- The order of the list does not matter.
+ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = []
-ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
- = []
-- Newtype
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
- ifCons = IfNewTyCon (
- IfCon { ifConOcc = con_occ,
- ifConFields = fields
- }),
- ifFamInst = famInst})
- = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
- ++ famInstCo famInst tc_occ
+ ifCons = IfNewTyCon (
+ IfCon { ifConOcc = con_occ,
+ ifConFields = fields
+ }),
+ ifFamInst = famInst})
+ = -- fields (names of selectors)
+ fields ++
+ -- implicit coerion and (possibly) family instance coercion
+ (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
+ -- data constructor and worker (newtypes don't have a wrapper)
+ [con_occ, mkDataConWorkerOcc con_occ]
+
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfDataTyCon cons,
ifFamInst = famInst})
- = nub (concatMap ifConFields cons) -- Eliminate duplicate fields
- ++ concatMap dc_occs cons
+ = -- fields (names of selectors)
+ nub (concatMap ifConFields cons) -- Eliminate duplicate fields
+ -- (possibly) family instance coercion;
+ -- there is no implicit coercion for non-newtypes
++ famInstCo famInst tc_occ
+ -- for each data constructor in order,
+ -- data constructor, worker, and (possibly) wrapper
+ ++ concatMap dc_occs cons
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
| otherwise = [con_occ, work_occ]
where
- con_occ = ifConOcc con_decl
- strs = ifConStricts con_decl
- wrap_occ = mkDataConWrapperOcc con_occ
- work_occ = mkDataConWorkerOcc con_occ
+ con_occ = ifConOcc con_decl -- DataCon namespace
+ wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
+ work_occ = mkDataConWorkerOcc con_occ -- Id namespace
+ strs = ifConStricts con_decl
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
|| not (null . ifConEqSpec $ con_decl)
|| isJust famInst
-- ToDo: may miss strictness in existential dicts
-ifaceDeclSubBndrs _other = []
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ ifSigs = sigs, ifATs = ats })
+ = -- dictionary datatype:
+ -- type constructor
+ tc_occ :
+ -- (possibly) newtype coercion
+ co_occs ++
+ -- data constructor (DataCon namespace)
+ -- data worker (Id namespace)
+ -- no wrapper (class dictionaries never have a wrapper)
+ [dc_occ, dcww_occ] ++
+ -- associated types
+ [ifName at | at <- ats ] ++
+ -- superclass selectors
+ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
+ -- operation selectors
+ [op | IfaceClassOp op _ _ <- sigs]
+ where
+ n_ctxt = length sc_ctxt
+ n_sigs = length sigs
+ tc_occ = mkClassTyConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
+ co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
+ | otherwise = []
+ dcww_occ = mkDataConWorkerOcc dc_occ
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+
+ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
+ ifFamInst = famInst})
+ = famInstCo famInst tc_occ
+
+ifaceDeclSubBndrs _ = []
-- coercion for data/newtype family instances
famInstCo Nothing baseOcc = []
nest 2 (ppr info) ]
pprIfaceDecl (IfaceForeign {ifName = tycon})
- = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+ = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = False, ifSynRhs = mono_ty,
ifFamInst = mbFamInst})
- = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifOpenSyn = True, ifSynRhs = mono_ty})
- = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr mono_ty)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
pprFamily mbFamInst])
where
pp_nd = case condecls of
- IfAbstractTyCon -> ptext SLIT("data")
- IfOpenDataTyCon -> ptext SLIT("data family")
- IfDataTyCon _ -> ptext SLIT("data")
- IfNewTyCon _ -> ptext SLIT("newtype")
+ IfAbstractTyCon -> ptext (sLit "data")
+ IfOpenDataTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ -> ptext (sLit "data")
+ IfNewTyCon _ -> ptext (sLit "newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifATs = ats, ifSigs = sigs,
ifRec = isrec})
- = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
+ = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprRec isrec,
sep (map ppr ats),
sep (map ppr sigs)])
-pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
-pprGen True = ptext SLIT("Generics: yes")
-pprGen False = ptext SLIT("Generics: no")
+pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
+pprGen True = ptext (sLit "Generics: yes")
+pprGen False = ptext (sLit "Generics: no")
-pprFamily Nothing = ptext SLIT("FamilyInstance: none")
-pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
+pprFamily Nothing = ptext (sLit "FamilyInstance: none")
+pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
pprIfaceTvBndrs tyvars]
-pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls tc IfAbstractTyCon = ptext (sLit "{- abstract -}")
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls tc IfOpenDataTyCon = empty
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
+pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
(map (pprIfaceConDecl tc) cs))
pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
ifConStricts = strs, ifConFields = fields })
= sep [main_payload,
- if is_infix then ptext SLIT("Infix") else empty,
+ if is_infix then ptext (sLit "Infix") else empty,
if null strs then empty
- else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
+ else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
if null fields then empty
- else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
+ else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
where
main_payload = ppr name <+> dcolon <+>
pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= sep [hsep [doubleQuotes (ftext name), ppr act,
- ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
+ ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
- ptext SLIT("=") <+> ppr rhs])
+ ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceInst where
ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
ifInstCls = cls, ifInstTys = mb_tcs})
- = hang (ptext SLIT("instance") <+> ppr flag
+ = hang (ptext (sLit "instance") <+> ppr flag
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
ifFamInstTyCon = tycon_id})
- = hang (ptext SLIT("family instance") <+>
+ = hang (ptext (sLit "family instance") <+>
ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
pprIfaceExpr add_par (IfaceExt v) = ppr v
pprIfaceExpr add_par (IfaceLit l) = ppr l
pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
+pprIfaceExpr add_par (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
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 noParens scrut <+> ptext SLIT("of")
+ = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+ <+> 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 noParens scrut <+> ptext SLIT("of")
+ = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+ <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{',
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
pprIfaceExpr add_par (IfaceCast expr co)
= sep [pprIfaceExpr parens expr,
- nest 2 (ptext SLIT("`cast`")),
+ nest 2 (ptext (sLit "`cast`")),
pprParendIfaceType co]
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
- = add_par (sep [ptext SLIT("let {"),
+ = add_par (sep [ptext (sLit "let {"),
nest 2 (ppr_bind (b, rhs)),
- ptext SLIT("} in"),
+ ptext (sLit "} in"),
pprIfaceExpr noParens body])
pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
- = add_par (sep [ptext SLIT("letrec {"),
+ = add_par (sep [ptext (sLit "letrec {"),
nest 2 (sep (map ppr_bind pairs)),
- ptext SLIT("} in"),
+ ptext (sLit "} in"),
pprIfaceExpr noParens body])
pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
------------------
instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
- ppr IfaceInlineMe = ptext SLIT("__inline_me")
- ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+ ppr IfaceInlineMe = ptext (sLit "__inline_me")
+ ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
instance Outputable IfaceConAlt where
------------------
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
- ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
+ ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
instance Outputable IfaceInfoItem where
- ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
+ ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
parens (pprIfaceExpr noParens unf)
- ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act
- ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity
- ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
- ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs")
- ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
+ ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act
+ ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
+ ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
+ ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
+ ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a
\end{code}
data GenIfaceEq a
= Equal -- Definitely exactly the same
| NotEqual -- Definitely different
- | EqBut a -- The same provided these Names have not changed
+ | EqBut (UniqSet a) -- The same provided these things have not changed
-type IfaceEq = GenIfaceEq NameSet
+type IfaceEq = GenIfaceEq Name
-instance Outputable IfaceEq where
- ppr Equal = ptext SLIT("Equal")
- ppr NotEqual = ptext SLIT("NotEqual")
- ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
+instance Outputable a => Outputable (GenIfaceEq a) where
+ ppr Equal = ptext (sLit "Equal")
+ ppr NotEqual = ptext (sLit "NotEqual")
+ ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset)
bool :: Bool -> IfaceEq
bool True = Equal
eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
+eq_ifaceExpr env (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
projects / ghc-hetmet.git / blobdiff