%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
+
\section[MkIface]{Print an interface for a module}
\begin{code}
module MkIface (
mkFinalIface,
- pprModDetails, pprIface, pprUsage
+ pprModDetails, pprIface, pprUsage,
+ ifaceTyCls,
) where
#include "HsVersions.h"
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
- ModuleLocation(..),
+ ModuleLocation(..), GhciMode(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
TyThing(..), DFunId, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
lookupVersion,
)
-import CmStaticInfo ( GhciMode(..) )
import CmdLineOpts
import Id ( idType, idInfo, isImplicitId, idCgInfo,
isLocalId, idName,
)
-import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon ( dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..) )
import CoreFVs ( ruleLhsFreeNames )
import NameSet
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
- tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
+ tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize,
+ isClassTyCon, isForeignTyCon
)
import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
import FieldLabel ( fieldLabelType )
-import Type ( splitSigmaTy, tidyTopType, deNoteType, namesOfType )
+import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
import SrcLoc ( noSrcLoc )
import Outputable
import Module ( ModuleName )
-import Util ( sortLt, unJust )
+import Util ( sortLt )
import ErrUtils ( dumpIfSet_dyn )
import Monad ( when )
-- so there's no need to write a new interface file. But even if
-- the usages have changed, the module version may not have.
- hi_file_path = unJust "mkFinalIface" (ml_hi_file location)
+ hi_file_path = ml_hi_file location
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
inst_dcls = map ifaceInstance (md_insts new_details)
- ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types new_details)
+ ty_cls_dcls = foldNameEnv ifaceTyCls_acc [] (md_types new_details)
rule_dcls = map ifaceRule (md_rules new_details)
orphan_mod = isOrphanModule (mi_module new_iface) new_details
isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
= any orphan_inst insts || any orphan_rule rules
where
- orphan_inst dfun_id = no_locals (namesOfType (dfun_head_type dfun_id))
+ orphan_inst dfun_id = no_locals (namesOfDFunHead (idType dfun_id))
orphan_rule rule = no_locals (ruleLhsFreeNames rule)
no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
- dfun_head_type dfun = case splitSigmaTy (idType dfun) of
- (_,_,head_ty) -> head_ty
- -- The 'dfun_head_type' is because of
- -- instance Foo a => Baz T where ...
- -- The decl is an orphan if Baz and T are both not locally defined,
- -- even if Foo *is* locally defined
\end{code}
+Implicit Ids and class tycons aren't included in interface files, so
+we miss them out of the accumulating parameter here.
+
\begin{code}
-ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
-ifaceTyCls (AClass clas) so_far
- = cls_decl : so_far
+ifaceTyCls_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+ifaceTyCls_acc (AnId id) so_far | isImplicitId id = so_far
+ifaceTyCls_acc (ATyCon id) so_far | isClassTyCon id = so_far
+ifaceTyCls_acc other so_far = ifaceTyCls other : so_far
+\end{code}
+
+Convert *any* TyThing into a RenamedTyClDecl. Used both for
+generating interface files and for the ':info' command in GHCi.
+
+\begin{code}
+ifaceTyCls :: TyThing -> RenamedTyClDecl
+ifaceTyCls (AClass clas) = cls_decl
where
cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
tcdName = getName clas,
= ASSERT(sel_tyvars == clas_tyvars)
ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
where
- (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+ (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id)
def_meth' = case def_meth of
NoDefMeth -> NoDefMeth
GenDefMeth -> GenDefMeth
DefMeth id -> DefMeth (getName id)
-ifaceTyCls (ATyCon tycon) so_far
- | isClassTyCon tycon = so_far
- | otherwise = ty_decl : so_far
+ifaceTyCls (ATyCon tycon) = ty_decl
where
ty_decl | isSynTyCon tycon
= TySynonym { tcdName = getName tycon,
tcdSysNames = map getName (tyConGenIds tycon),
tcdLoc = noSrcLoc }
+ | isForeignTyCon tycon
+ = ForeignType { tcdName = getName tycon,
+ tcdFoType = DNType, -- The only case at present
+ tcdLoc = noSrcLoc }
+
| otherwise = pprPanic "ifaceTyCls" (ppr tycon)
tyvars = tyConTyVars tycon
where
(tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
field_labels = dataConFieldLabels data_con
- strict_marks = dataConStrictMarks data_con
+ strict_marks = drop (length ex_theta) (dataConStrictMarks data_con)
+ -- The 'drop' is because dataConStrictMarks
+ -- includes the existential dictionaries
details | null field_labels
= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
- VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
+ VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys))
| otherwise
= RecCon (zipWith mk_field strict_marks field_labels)
- mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
- mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
- mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
-
mk_field strict_mark field_label
- = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
+ = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
-ifaceTyCls (AnId id) so_far
- | isImplicitId id = so_far
- | otherwise = iface_sig : so_far
+ifaceTyCls (AnId id) = iface_sig
where
iface_sig = IfaceSig { tcdName = getName id,
tcdType = toHsType id_type,
caf_info = cgCafInfo cg_info
hs_idinfo | opt_OmitInterfacePragmas = []
- | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
+ | otherwise = arity_hsinfo ++ caf_hsinfo ++
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
NoCafRefs -> [HsNoCafRefs]
otherwise -> []
- ------------ CPR Info --------------
- cpr_hsinfo = case cprInfo id_info of
- ReturnsCPR -> [HsCprInfo]
- NoCPRInfo -> []
-
------------ Strictness --------------
- strict_hsinfo = case strictnessInfo id_info of
- NoStrictnessInfo -> []
- info -> [HsStrictness info]
+ strict_hsinfo = case newStrictnessInfo id_info of
+ Nothing -> []
+ Just sig -> [HsStrictness sig]
------------ Worker --------------
work_info = workerInfo id_info
projects / ghc-hetmet.git / blobdiff