X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=11235cef2e07e8e1e191f8a62891c1f78bb2089c;hp=b86aa92493b24d57cb9293476ebbc5ebe68da58d;hb=2a8cdc3aee5997374273e27365f92c161aca8453;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b86aa92..11235ce 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -4,8 +4,6 @@ \begin{code} module MkIface ( - pprModIface, showIface, -- Print the iface in Foo.hi - mkUsageInfo, -- Construct the usage info for a module mkIface, -- Build a ModIface from a ModGuts, @@ -13,8 +11,10 @@ module MkIface ( writeIfaceFile, -- Write the interface file - checkOldIface -- See if recompilation is required, by + checkOldIface, -- See if recompilation is required, by -- comparing version information + + tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where \end{code} @@ -175,21 +175,40 @@ compiled with -O. I think this is the case.] \begin{code} #include "HsVersions.h" -import HsSyn -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), - IfaceRule(..), IfaceInst(..), IfaceExtName(..), - eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, - eqMaybeBy, eqListBy, visibleIfConDecls, - tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule ) -import LoadIface ( readIface, loadInterface ) -import BasicTypes ( Version, initialVersion, bumpVersion ) +import IfaceSyn -- All of it +import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext, + ifaceTyConOccName ) +import LoadIface ( readIface, loadInterface, pprModIface ) +import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) +import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), + arityInfo, cafInfo, newStrictnessInfo, + workerInfo, unfoldingInfo, inlinePragInfo ) +import NewDemand ( isTopSig ) +import CoreSyn +import Class ( classExtraBigSig, classTyCon ) +import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), + isRecursiveTyCon, isForeignTyCon, + isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, + tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, + tyConArity, tyConTyVars, algTyConRhs, tyConExtName, + tyConFamInst_maybe ) +import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, + dataConTyCon, dataConIsInfix, dataConUnivTyVars, + dataConExTyVars, dataConEqSpec, dataConTheta, + dataConOrigArgTys ) +import Type ( TyThing(..), splitForAllTys, funResultTy ) +import TcType ( deNoteType ) +import TysPrim ( alphaTyVars ) +import InstEnv ( Instance(..) ) +import FamInstEnv ( FamInst(..) ) import TcRnMonad import HscTypes ( ModIface(..), ModDetails(..), - ModGuts(..), IfaceExport, - HscEnv(..), hscEPS, Dependencies(..), FixItem(..), + ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), + FixItem(..), ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, - typeEnvElts, + typeEnvElts, GenAvailInfo(..), availName, ExternalPackageState(..), Usage(..), IsBootInterface, @@ -199,7 +218,6 @@ import HscTypes ( ModIface(..), ModDetails(..), import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) -import StaticFlags ( opt_HiVersion ) import Name ( Name, nameModule, nameOccName, nameParent, isExternalName, isInternalName, nameParent_maybe, isWiredInName, isImplicitName, NamedThing(..) ) @@ -213,10 +231,10 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, occNameFS, isTcOcc ) import Module import Outputable -import Util ( createDirectoryHierarchy, directoryOf ) -import Util ( sortLe, seqList ) -import Binary ( getBinFileWithDict ) -import BinIface ( writeBinIface, v_IgnoreHiWay ) +import BasicTypes ( Version, initialVersion, bumpVersion, isAlwaysActive, + Activation(..), RecFlag(..), boolToRecFlag ) +import Util ( createDirectoryHierarchy, directoryOf, sortLe, seqList, lengthIs ) +import BinIface ( writeBinIface ) import Unique ( Unique, Uniquable(..) ) import ErrUtils ( dumpIfSet_dyn, showPass ) import Digraph ( stronglyConnComp, SCC(..) ) @@ -226,11 +244,10 @@ import PackageConfig ( PackageId ) import FiniteMap import FastString -import DATA_IOREF ( writeIORef ) import Monad ( when ) import List ( insert ) import Maybes ( orElse, mapCatMaybes, isNothing, isJust, - expectJust, MaybeErr(..) ) + expectJust, catMaybes, MaybeErr(..) ) \end{code} @@ -251,17 +268,18 @@ mkIface :: HscEnv -- is identical, so no need to write it mkIface hsc_env maybe_old_iface - (ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_usages = usages, - mg_deps = deps, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = src_deprecs }) - (ModDetails{ md_insts = insts, - md_rules = rules, - md_types = type_env, - md_exports = exports }) + (ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_usages = usages, + mg_deps = deps, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = src_deprecs }) + (ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_types = type_env, + md_exports = exports }) -- NB: notice that mkIface does not look at the bindings -- only at the TypeEnv. The previous Tidy phase has @@ -279,10 +297,14 @@ mkIface hsc_env maybe_old_iface -- Don't put implicit Ids and class tycons in the interface file -- Nor wired-in things; the compiler knows about them anyhow - ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] - ; deprecs = mkIfaceDeprec src_deprecs - ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules - ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts + ; fixities = [ (occ,fix) + | FixItem occ fix _ <- nameEnvElts fix_env] + ; deprecs = mkIfaceDeprec src_deprecs + ; iface_rules = map (coreRuleToIfaceRule + ext_nm_lhs ext_nm_rhs) rules + ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts + ; iface_fam_insts = map (famInstToIfaceFamInst ext_nm_lhs) + fam_insts ; intermediate_iface = ModIface { mi_module = this_mod, @@ -291,6 +313,7 @@ mkIface hsc_env maybe_old_iface mi_usages = usages, mi_exports = mkIfaceExports exports, mi_insts = sortLe le_inst iface_insts, + mi_fam_insts= sortLe le_fam_inst iface_fam_insts, mi_rules = sortLe le_rule iface_rules, mi_fixities = fixities, mi_deprecs = deprecs, @@ -324,11 +347,13 @@ mkIface hsc_env maybe_old_iface ; return (new_iface, no_change_at_all) } where - r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 - i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 + r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 + i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 + i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2 dflags = hsc_dflags hsc_env deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) + ifFamInstTyConOcc = ifaceTyConOccName . ifFamInstTyCon ----------------------------- @@ -364,17 +389,17 @@ mkExtNameFn hsc_env eps this_mod occ = nameOccName name par_occ = nameOccName (nameParent name) -- The version of the *parent* is the one want - vers = lookupVersion mod par_occ + vers = lookupVersion mod par_occ occ - lookupVersion :: Module -> OccName -> Version + lookupVersion :: Module -> OccName -> OccName -> Version -- Even though we're looking up a home-package thing, in -- one-shot mode the imported interfaces may be in the PIT - lookupVersion mod occ - = mi_ver_fn iface occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ) + lookupVersion mod par_occ occ + = mi_ver_fn iface par_occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr par_occ <+> ppr occ) where iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` - pprPanic "lookupVers2" (ppr mod <+> ppr occ) + pprPanic "lookupVers2" (ppr mod <+> ppr par_occ <+> ppr occ) --------------------- @@ -772,44 +797,42 @@ checkOldIface hsc_env mod_summary source_unchanged maybe_iface } check_old_iface hsc_env mod_summary source_unchanged maybe_iface - = -- CHECK WHETHER THE SOURCE HAS CHANGED - ifM (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - `thenM_` + = do -- CHECK WHETHER THE SOURCE HAS CHANGED + { ifM (not source_unchanged) + (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) -- If the source has changed and we're in interactive mode, avoid reading -- an interface; just return the one we might have been supplied with. - getGhcMode `thenM` \ ghc_mode -> - if (ghc_mode == Interactive || ghc_mode == JustTypecheck) - && not source_unchanged then - returnM (outOfDate, maybe_iface) - else - - case maybe_iface of { - Just old_iface -> do -- Use the one we already have - recomp <- checkVersions hsc_env source_unchanged old_iface - return (recomp, Just old_iface) - - ; Nothing -> + ; ghc_mode <- getGhcMode + ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck) + && not source_unchanged then + return (outOfDate, maybe_iface) + else + case maybe_iface of { + Just old_iface -> do -- Use the one we already have + { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) + ; recomp <- checkVersions hsc_env source_unchanged old_iface + ; return (recomp, Just old_iface) } + + ; Nothing -> do -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it - let - iface_path = msHiFilePath mod_summary - in - readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result -> - case read_result of { - Failed err -> -- Old interface file not found, or garbled; give up - traceIf (text "FYI: cannot read old interface file:" - $$ nest 4 err) `thenM_` - returnM (outOfDate, Nothing) + { let iface_path = msHiFilePath mod_summary + ; read_result <- readIface (ms_mod mod_summary) iface_path False + ; case read_result of { + Failed err -> do -- Old interface file not found, or garbled; give up + { traceIf (text "FYI: cannot read old interface file:" + $$ nest 4 err) + ; return (outOfDate, Nothing) } - ; Succeeded iface -> + ; Succeeded iface -> do -- We have got the old iface; check its versions - checkVersions hsc_env source_unchanged iface `thenM` \ recomp -> - returnM (recomp, Just iface) - }} + { traceIf (text "Read the interface file" <+> text iface_path) + ; recomp <- checkVersions hsc_env source_unchanged iface + ; returnM (recomp, Just iface) + }}}}} \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -842,7 +865,9 @@ checkVersions hsc_env source_unchanged iface -- (in which case we are done with this module) or it'll fail (in which -- case we'll compile the module from scratch anyhow). -- - -- We do this regardless of compilation mode + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } ; let this_pkg = thisPackage (hsc_dflags hsc_env) @@ -960,113 +985,292 @@ checkList (check:checks) = check `thenM` \ recompile -> %************************************************************************ %* * - Printing interfaces + Converting things to their Iface equivalents %* * %************************************************************************ \begin{code} -showIface :: FilePath -> IO () --- Read binary interface, and print it out -showIface filename = do - -- skip the version check; we don't want to worry about profiled vs. - -- non-profiled interfaces, for example. - writeIORef v_IgnoreHiWay True - iface <- Binary.getBinFileWithDict filename - printDump (pprModIface iface) - where -\end{code} - +tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl +-- Assumption: the thing is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- Reason: Iface stuff uses OccNames, and the conversion here does +-- not do tidying on the way +tyThingToIfaceDecl ext (AnId id) + = IfaceId { ifName = getOccName id, + ifType = toIfaceType ext (idType id), + ifIdInfo = info } + where + info = case toIfaceIdInfo ext (idInfo id) of + [] -> NoInfo + items -> HasInfo items + +tyThingToIfaceDecl ext (AClass clas) + = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, + ifName = getOccName clas, + ifTyVars = toIfaceTvBndrs clas_tyvars, + ifFDs = map toIfaceFD clas_fds, + ifATs = map (tyThingToIfaceDecl ext . ATyCon) clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifRec = boolToRecFlag (isRecursiveTyCon tycon) } + where + (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas -\begin{code} -pprModIface :: ModIface -> SDoc --- Show a ModIface -pprModIface iface - = vcat [ ptext SLIT("interface") - <+> ppr (mi_module iface) <+> pp_boot - <+> ppr (mi_mod_vers iface) <+> pp_sub_vers - <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) - <+> int opt_HiVersion - <+> ptext SLIT("where") - , vcat (map pprExport (mi_exports iface)) - , pprDeps (mi_deps iface) - , vcat (map pprUsage (mi_usages iface)) - , pprFixities (mi_fixities iface) - , vcat (map pprIfaceDecl (mi_decls iface)) - , vcat (map ppr (mi_insts iface)) - , vcat (map ppr (mi_rules iface)) - , pprDeprecs (mi_deprecs iface) - ] + toIfaceClassOp (sel_id, def_meth) + = ASSERT(sel_tyvars == clas_tyvars) + IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) + op_ty = funResultTy rho_ty + + toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2) + +tyThingToIfaceDecl ext (ATyCon tycon) + | isSynTyCon tycon + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifOpenSyn = syn_isOpen, + ifSynRhs = toIfaceType ext syn_tyki } + + | isAlgTyCon tycon + = IfaceData { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifGeneric = tyConHasGenerics tycon, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} + + | isForeignTyCon tycon + = IfaceForeign { ifName = getOccName tycon, + ifExtName = tyConExtName tycon } + + | isPrimTyCon tycon || isFunTyCon tycon + -- Needed in GHCi for ':info Int#', for example + = IfaceData { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), + ifCtxt = [], + ifCons = IfAbstractTyCon, + ifGadtSyntax = False, + ifGeneric = False, + ifRec = NonRecursive, + ifFamInst = Nothing } + + | otherwise = pprPanic "toIfaceDecl" (ppr tycon) + where + tyvars = tyConTyVars tycon + (syn_isOpen, syn_tyki) = case synTyConRhs tycon of + OpenSynTyCon ki -> (True , ki) + SynonymTyCon ty -> (False, ty) + + ifaceConDecls (NewTyCon { data_con = con }) = + IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = + IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls OpenDataTyCon = IfOpenDataTyCon + ifaceConDecls OpenNewTyCon = IfOpenNewTyCon + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The last case happens when a TyCon has been trimmed during tidying + -- Furthermore, tyThingToIfaceDecl is also used + -- in TcRnDriver for GHCi, when browsing a module, in which case the + -- AbstractTyCon case is perfectly sensible. + + ifaceConDecl data_con + = IfCon { ifConOcc = getOccName (dataConName data_con), + ifConInfix = dataConIsInfix data_con, + ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), + ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), + ifConEqSpec = to_eq_spec (dataConEqSpec data_con), + ifConCtxt = toIfaceContext ext (dataConTheta data_con), + ifConArgTys = map (toIfaceType ext) + (dataConOrigArgTys data_con), + ifConFields = map getOccName + (dataConFieldLabels data_con), + ifConStricts = dataConStrictMarks data_con } + + to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] + + famInstToIface Nothing = Nothing + famInstToIface (Just (famTyCon, instTys)) = + Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys) + +tyThingToIfaceDecl ext (ADataCon dc) + = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier + + +-------------------------- +instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst +instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls, is_tcs = mb_tcs, + is_orph = orph }) + = IfaceInst { ifDFun = getOccName dfun_id, + ifOFlag = oflag, + ifInstCls = ext_lhs cls, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } where - pp_boot | mi_boot iface = ptext SLIT("[boot]") - | otherwise = empty + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + +-------------------------- +famInstToIfaceFamInst :: (Name -> IfaceExtName) -> FamInst -> IfaceFamInst +famInstToIfaceFamInst ext_lhs fi@(FamInst { fi_tycon = tycon, + fi_fam = fam, fi_tcs = mb_tcs }) + = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext_lhs tycon + , ifFamInstFam = ext_lhs fam + , ifFamInstTys = map do_rough mb_tcs } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + +-------------------------- +toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] +toIfaceIdInfo ext id_info + = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + strict_hsinfo = case newStrictnessInfo id_info of + Just sig | not (isTopSig sig) -> Just (HsStrictness sig) + _other -> Nothing + + ------------ Worker -------------- + work_info = workerInfo id_info + has_worker = case work_info of { HasWorker _ _ -> True; other -> False } + wrkr_hsinfo = case work_info of + HasWorker work_id wrap_arity -> + Just (HsWorker (ext (idName work_id)) wrap_arity) + NoWorker -> Nothing + + ------------ Unfolding -------------- + -- The unfolding is redundant if there is a worker + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isAlwaysActive inline_prag = Nothing + | no_unfolding && not has_worker = Nothing + -- If the iface file give no unfolding info, we + -- don't need to say when inlining is OK! + | otherwise = Just (HsInline inline_prag) + +-------------------------- +coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names + -> (Name -> IfaceExtName) -- For the RHS names + -> CoreRule -> IfaceRule +coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule (mkIfaceExtName fn) + +coreRuleToIfaceRule ext_lhs ext_rhs + (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, ru_orph = orph }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, + ifRuleHead = ext_lhs fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr ext_rhs rhs, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) + do_arg arg = toIfaceExpr ext_lhs arg + +bogusIfaceRule :: IfaceExtName -> IfaceRule +bogusIfaceRule id_name + = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } - exp_vers = mi_exp_vers iface - rule_vers = mi_rule_vers iface +--------------------- +toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr +toIfaceExpr ext (Var v) = toIfaceVar ext v +toIfaceExpr ext (Lit l) = IfaceLit l +toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) +toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) +toIfaceExpr ext (App f a) = toIfaceApp ext f [a] +toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as) +toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) +toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co) +toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) - pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty - | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) -\end{code} +--------------------- +toIfaceNote ext (SCC cc) = IfaceSCC cc +toIfaceNote ext InlineMe = IfaceInlineMe +toIfaceNote ext (CoreNote s) = IfaceCoreNote s -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C +--------------------- +toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) +toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] -\begin{code} -pprExport :: IfaceExport -> SDoc -pprExport (mod, items) - = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ] - where - pp_avail :: GenAvailInfo OccName -> SDoc - pp_avail (Avail occ) = ppr occ - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = ppr n <> pp_export ns - | otherwise = ppr n <> char '|' <> pp_export (n':ns) - - pp_export [] = empty - pp_export names = braces (hsep (map ppr names)) - -pprUsage :: Usage -> SDoc -pprUsage usage - = hsep [ptext SLIT("import"), ppr (usg_name usage), - int (usg_mod usage), - pp_export_version (usg_exports usage), - int (usg_rules usage), - pp_versions (usg_entities usage) ] - where - pp_versions nvs = hsep [ ppr n <+> int v | (n,v) <- nvs ] - pp_export_version Nothing = empty - pp_export_version (Just v) = int v - -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) - = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), - ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), - ptext SLIT("orphans:") <+> fsep (map ppr orphs) - ] - where - ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - ppr_boot True = text "[boot]" - ppr_boot False = empty +--------------------- +toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r) -pprIfaceDecl :: (Version, IfaceDecl) -> SDoc -pprIfaceDecl (ver, decl) - = ppr_vers ver <+> ppr decl +--------------------- +toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) + | otherwise = IfaceDataAlt (getOccName dc) + where + tc = dataConTyCon dc + +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) +toIfaceApp ext (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | isTupleTyCon tc && saturated + -> IfaceTuple (tupleTyConBoxity tc) tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map (toIfaceExpr ext) val_args + tc = dataConTyCon dc + + other -> mkIfaceApps ext (toIfaceVar ext v) as + +toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as + +mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as + +--------------------- +toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr +toIfaceVar ext v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) + -- Foreign calls have special syntax + | isExternalName name = IfaceExt (ext name) + | otherwise = IfaceLcl (occNameFS (nameOccName name)) where - -- Print the version for the decl - ppr_vers v | v == initialVersion = empty - | otherwise = int v - -pprFixities :: [(OccName, Fixity)] -> SDoc -pprFixities [] = empty -pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes - where - pprFix (occ,fix) = ppr fix <+> ppr occ - -pprDeprecs NoDeprecs = empty -pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) -pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs) - where - pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt) + name = idName v \end{code}