)
import CmdLineOpts
-import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
+import Id ( Id, idType, idInfo, omitIfaceSigForId, isExportedId, hasNoBinding,
idSpecialisation, idName, setIdInfo
)
import Var ( isId )
import IdInfo -- Lots
import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
- bindersOfBinds
+ bindersOfBinds, mustHaveLocalBinding
)
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
-import Name ( isLocallyDefined, getName,
- Name, NamedThing(..)
- )
+import Name ( getName, nameModule, Name, NamedThing(..) )
import Name -- Env
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
- tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
+ tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
)
import Class ( classExtraBigSig, DefMeth(..) )
import FieldLabel ( fieldLabelType )
where
-- The competed type environment is gotten from
-- a) keeping the types and classes
- -- b) removing all Ids, and Ids with correct IdInfo
+ -- b) removing all Ids,
+ -- c) adding Ids with correct IdInfo, including unfoldings,
-- gotten from the bindings
- -- From (b) we keep only those Ids with Global names, plus Ids
+ -- From (c) we keep only those Ids with Global names, plus Ids
-- accessible from them (notably via unfoldings)
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
DefMeth id -> DefMeth (getName id)
ifaceTyCls (ATyCon tycon) so_far
- = ty_decl : so_far
-
+ | isClassTyCon tycon = so_far
+ | otherwise = ty_decl : so_far
where
ty_decl | isSynTyCon tycon
= TySynonym (getName tycon)(toHsTyVars tyvars)
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
- need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
+ need_id needed_set id = id `elemVarSet` needed_set || isExportedId id
go needed [] emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
bottoming_fn = isBottomingStrictness (strictnessInfo core_idinfo)
unfolding = mkTopUnfolding rhs
- rhs_is_small = neverUnfold unfolding
+ rhs_is_small = not (neverUnfold unfolding)
unfold_info | show_unfold = unfolding
| otherwise = noUnfolding
find_fvs expr = exprSomeFreeVars interestingId expr
-interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
+interestingId id = isId id && mustHaveLocalBinding id
\end{code}
writeIface :: FilePath -> ModIface -> IO ()
writeIface hi_path mod_iface
= do { if_hdl <- openFile hi_path WriteMode
- ; printForIface if_hdl (pprIface mod_iface)
+ ; printForIface if_hdl from_this_mod (pprIface mod_iface)
; hClose if_hdl
}
+ where
+ -- Print names unqualified if they are from this module
+ from_this_mod n = nameModule n == this_mod
+ this_mod = mi_module mod_iface
pprIface :: ModIface -> SDoc
pprIface iface
pprDeprecs deprecs = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
where
guts = case deprecs of
- DeprecAll txt -> ptext txt
+ DeprecAll txt -> doubleQuotes (ptext txt)
DeprecSome env -> pp_deprecs env
pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
where
- pp_deprec (name, txt) = pprOcc name <+> ptext txt
+ pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)
\end{code}