X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=9f31e7019bd92a4fdc31293cf487cb77e4739426;hb=962aaded9a544188b7d86639ab4993af205e9d72;hp=2b35f372d7490d33c6745d24d773814a09d2fac1;hpb=42b63073fb5e71fcd539ab80289cf6cf2a5b9641;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 2b35f37..9f31e70 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -38,7 +38,7 @@ import HscTypes ( VersionInfo(..), ModIface(..), ) import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, idCgInfo ) +import Id ( idType, idInfo, isImplicitId, idCafInfo ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo -- Lots import CoreSyn ( CoreRule(..), IdCoreRule ) @@ -53,9 +53,10 @@ import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta, isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, isSynTyCon, isAlgTyCon, isForeignTyCon, getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity ) -import Class ( classExtraBigSig, classTyCon, DefMeth(..) ) +import Class ( classExtraBigSig, classTyCon ) import FieldLabel ( fieldLabelType ) -import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead ) +import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead, + mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys ) import SrcLoc ( noSrcLoc ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, @@ -63,6 +64,7 @@ import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, extendModuleEnv_C, moduleEnvElts ) import Outputable +import DriverUtil ( createDirectoryHierarchy, directoryOf ) import Util ( sortLt, dropList, seqList ) import Binary ( getBinFileWithDict ) import BinIface ( writeBinIface, v_IgnoreHiVersion ) @@ -167,9 +169,9 @@ mkIface hsc_env location maybe_old_iface ; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls -- Write the interface file, if necessary - ; when (must_write_hi_file maybe_diffs) - (writeBinIface hi_file_path final_iface) --- (writeIface hi_file_path final_iface) + ; when (must_write_hi_file maybe_diffs) $ do + createDirectoryHierarchy (directoryOf hi_file_path) + writeBinIface hi_file_path final_iface -- Debug printing ; write_diffs dflags final_iface maybe_diffs @@ -180,6 +182,7 @@ mkIface hsc_env location maybe_old_iface where dflags = hsc_dflags hsc_env ghci_mode = hsc_mode hsc_env + omit_pragmas = dopt Opt_OmitInterfacePragmas dflags must_write_hi_file Nothing = False must_write_hi_file (Just _diffs) = ghci_mode /= Interactive @@ -192,7 +195,7 @@ mkIface hsc_env location maybe_old_iface hi_file_path = ml_hi_file location new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls inst_dcls = map ifaceInstance insts - ty_cls_dcls = foldNameEnv ifaceTyThing_acc [] types + ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types rule_dcls = map ifaceRule rules orphan_mod = isOrphanModule impl @@ -223,19 +226,21 @@ Implicit Ids and class tycons aren't included in interface files, so we miss them out of the accumulating parameter here. \begin{code} -ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] -ifaceTyThing_acc (ADataCon dc) so_far = so_far -ifaceTyThing_acc (AnId id) so_far | isImplicitId id = so_far -ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far -ifaceTyThing_acc other so_far = ifaceTyThing other : so_far +ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] +-- Don't put implicit things into the result +ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far +ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far +ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far +ifaceTyThing_acc omit_pragmas other so_far + = ifaceTyThing omit_pragmas 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} -ifaceTyThing :: TyThing -> RenamedTyClDecl -ifaceTyThing (AClass clas) = cls_decl +ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl +ifaceTyThing omit_pragmas (AClass clas) = cls_decl where cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, tcdName = getName clas, @@ -261,7 +266,7 @@ ifaceTyThing (AClass clas) = cls_decl (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) op_ty = tcFunResultTy rho_ty -ifaceTyThing (ATyCon tycon) = ty_decl +ifaceTyThing omit_pragmas (ATyCon tycon) = ty_decl where ty_decl | isSynTyCon tycon = TySynonym { tcdName = getName tycon, @@ -329,20 +334,19 @@ ifaceTyThing (ATyCon tycon) = ty_decl mk_field strict_mark field_label = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label))) -ifaceTyThing (AnId id) = iface_sig +ifaceTyThing omit_pragmas (AnId id) = iface_sig where iface_sig = IfaceSig { tcdName = getName id, tcdType = toHsType id_type, tcdIdInfo = hs_idinfo, - tcdLoc = noSrcLoc } + tcdLoc = noSrcLoc } id_type = idType id id_info = idInfo id - cg_info = idCgInfo id arity_info = arityInfo id_info - caf_info = cgCafInfo cg_info + caf_info = idCafInfo id - hs_idinfo | opt_OmitInterfacePragmas + hs_idinfo | omit_pragmas = [] | otherwise = catMaybes [arity_hsinfo, caf_hsinfo, @@ -380,6 +384,23 @@ ifaceTyThing (AnId id) = iface_sig unfold_hsinfo | neverUnfold unfold_info || has_worker = Nothing | otherwise = Just (HsUnfold inline_prag (toUfExpr rhs)) + + +ifaceTyThing omit_pragmas (ADataCon dc) + -- This case only happens in the call to ifaceThing in InteractiveUI + -- Otherwise DataCons are filtered out in ifaceThing_acc + = IfaceSig { tcdName = getName dc, + tcdType = toHsType full_ty, + tcdIdInfo = [], + tcdLoc = noSrcLoc } + where + (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc + + -- The "stupid context" isn't part of the wrapper-Id type + -- (for better or worse -- see note in DataCon.lhs), so we + -- have to make it up here + full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) + (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) \end{code} \begin{code} @@ -492,13 +513,14 @@ mkUsageInfo hsc_env eps where usages = catMaybes [ mkUsage mod_name | (mod_name,_) <- moduleEnvElts dep_mods] + -- ToDo: do we need to sort into canonical order? hpt = hsc_HPT hsc_env pit = eps_PIT eps import_all mod = case lookupModuleEnv dir_imp_mods mod of - Just (_,imp_all) -> imp_all - Nothing -> False + Just (_, Nothing) -> True + _ -> False -- ent_map groups together all the things imported and used -- from a particular module in this package @@ -551,6 +573,7 @@ mkUsageInfo hsc_env eps ent_vers = [(n, lookupVersion version_env n) | n <- sortLt lt_occ used_names ] lt_occ n1 n2 = nameOccName n1 < nameOccName n2 + -- ToDo: is '<' on OccNames the right thing; may differ between runs? \end{code} \begin{code}