X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=24e51c92515b3c21f0c8dead3b37aecf5255e5f0;hb=f83a5a68edb4b9dbdff1eebeed84527711efc728;hp=9995ca3c48cf95d00cd57c634bce00a78aa67b97;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 9995ca3..24e51c9 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -46,14 +46,16 @@ import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons ) -import Class ( Class, classBigSig ) +import Class ( Class, classExtraBigSig ) import FieldLabel ( fieldLabelName, fieldLabelType ) -import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, - Type, ThetaType +import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, + deNoteType, classesToPreds, + Type, ThetaType, PredType(..), ClassContext ) import PprType import PprCore ( pprIfaceUnfolding, pprCoreRule ) +import FunDeps ( pprFundeps ) import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) import Bag ( bagToList, isEmptyBag ) @@ -74,6 +76,10 @@ We then have one-function-per-block-of-interface-stuff, e.g., @ifaceExportList@ produces the @__exports__@ section; it appends to the handle provided by @startIface@. +NOTE: ALWAYS remember that ghc-iface.lprl rewrites the interface file, +so you have to keep it in synch with the code below. Otherwise you'll +lose the happiest years of your life, believe me... -- SUP + \begin{code} startIface :: Module -> InterfaceDetails -> IO (Maybe Handle) -- Nothing <=> don't do an interface @@ -84,13 +90,14 @@ ifaceDecls :: Maybe Handle -> [Id] -- Ids used at code-gen time; they have better pragma info! -> [CoreBind] -- In dependency order, later depend on earlier -> [ProtoCoreRule] -- Rules + -> [Deprecation Name] -> IO () endIface :: Maybe Handle -> IO () \end{code} \begin{code} -startIface mod (has_orphans, import_usages, ExportEnv avails fixities) +startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _) = case opt_ProduceHi of Nothing -> return Nothing ; -- not producing any .hi file @@ -113,12 +120,14 @@ endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \begin{code} -ifaceDecls Nothing tycons classes inst_info final_ids simplified rules = return () +ifaceDecls Nothing tycons classes inst_info final_ids simplified rules _ = return () ifaceDecls (Just hdl) tycons classes inst_infos - final_ids binds + final_ids + binds orphan_rules -- Rules defined locally for an Id that is *not* defined locally + deprecations | null_decls = return () -- You could have a module with just (re-)exports/instances in it | otherwise @@ -128,19 +137,21 @@ ifaceDecls (Just hdl) ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids) final_ids binds >>= \ emitted_ids -> ifaceRules hdl orphan_rules emitted_ids >> - return () + ifaceDeprecations hdl deprecations where orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule | ProtoCoreRule _ _ rule <- orphan_rules] - null_decls = null binds && - null tycons && - null classes && - isEmptyBag inst_infos && - null orphan_rules + null_decls = null binds && + null tycons && + null classes && + isEmptyBag inst_infos && + null orphan_rules && + null deprecations \end{code} \begin{code} +ifaceImports :: Handle -> VersionInfo Name -> IO () ifaceImports if_hdl import_usages = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where @@ -160,6 +171,7 @@ ifaceImports if_hdl import_usages upp_import_versions (Specifically nvs) = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] +{- SUP: What's this?? ifaceModuleDeps if_hdl [] = return () ifaceModuleDeps if_hdl mod_deps = let @@ -170,7 +182,9 @@ ifaceModuleDeps if_hdl mod_deps in printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >> hPutStr if_hdl "\n" +-} +ifaceExports :: Handle -> Avails -> IO () ifaceExports if_hdl [] = return () ifaceExports if_hdl avails = hPutCol if_hdl do_one_module (fmToList export_fm) @@ -191,35 +205,45 @@ ifaceExports if_hdl avails hsep (map upp_avail (sortLt lt_avail avails)) ] <> semi +ifaceFixities :: Handle -> Fixities -> IO () ifaceFixities if_hdl [] = return () ifaceFixities if_hdl fixities = hPutCol if_hdl upp_fixity fixities +ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO () ifaceRules if_hdl rules emitted | null orphan_rule_pretties && null local_id_pretties = return () | otherwise - = do printForIface if_hdl (vcat [ + = printForIface if_hdl (vcat [ ptext SLIT("{-## __R"), - vcat orphan_rule_pretties, - vcat local_id_pretties, - ptext SLIT("##-}") - ]) - - return () + ]) where - orphan_rule_pretties = [ pprCoreRule (Just fn) rule <+> semi + orphan_rule_pretties = [ pprCoreRule (Just fn) rule | ProtoCoreRule _ fn rule <- rules ] - local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi + local_id_pretties = [ pprCoreRule (Just fn) rule | fn <- varSetElems emitted, rule <- rulesRules (getIdSpecialisation fn), all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) - -- Spit out a rule only if all its lhs free vars are eemitted + -- Spit out a rule only if all its lhs free vars are emitted ] + +ifaceDeprecations :: Handle -> [Deprecation Name] -> IO () +ifaceDeprecations if_hdl [] = return () +ifaceDeprecations if_hdl deprecations + = printForIface if_hdl (vcat [ + ptext SLIT("{-## __D"), + vcat [ pprIfaceDeprec d <> semi | d <- deprecations ], + ptext SLIT("##-}") + ]) + where + -- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now + pprIfaceDeprec (Deprecation (IEModuleContents _) txt) = doubleQuotes (ppr txt) + pprIfaceDeprec (Deprecation (IEVar n) txt) = ppr n <+> doubleQuotes (ppr txt) \end{code} %************************************************************************ @@ -259,7 +283,8 @@ ifaceInstances if_hdl inst_infos -- instance Foo Tibble where ... -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. - forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys)) + forall_ty = mkSigmaTy tvs (classesToPreds theta) + (deNoteType (mkDictTy clas tys)) renumbered_ty = tidyTopType forall_ty in hcat [ptext SLIT("instance "), pprType renumbered_ty, @@ -465,7 +490,7 @@ ifaceBinds hdl needed_ids final_ids binds %************************************************************************ \begin{code} -ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons )) +ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons)) ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes)) for_iface_name name = isLocallyDefined name && @@ -493,7 +518,7 @@ ifaceTyCon tycon ifaceTyCon tycon | isAlgTyCon tycon = hsep [ ptext keyword, - ppr_decl_context (tyConTheta tycon), + ppr_decl_class_context (tyConTheta tycon), ppr (getName tycon), pprTyVarBndrs (tyConTyVars tycon), ptext SLIT("="), @@ -527,7 +552,7 @@ ifaceTyCon tycon ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs) - <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>") + <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>") ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty @@ -546,24 +571,25 @@ ifaceTyCon tycon ifaceClass clas = hsep [ptext SLIT("class"), - ppr_decl_context sc_theta, + ppr_decl_class_context sc_theta, ppr clas, -- Print the name pprTyVarBndrs clas_tyvars, + pprFundeps clas_fds, pp_ops, semi ] where - (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas + (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - pp_ops | null sel_ids = empty - | otherwise = hsep [ptext SLIT("where"), - braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms))) - ] + pp_ops | null op_stuff = empty + | otherwise = hsep [ptext SLIT("where"), + braces (hsep (punctuate semi (map ppr_classop op_stuff))) + ] - ppr_classop sel_id maybe_defm + ppr_classop (sel_id, dm_id, explicit_dm) = ASSERT( sel_tyvars == clas_tyvars) hsep [ppr (getOccName sel_id), - if maybeToBool maybe_defm then equals else empty, + if explicit_dm then equals else empty, dcolon, ppr op_ty ] @@ -574,9 +600,23 @@ ppr_decl_context :: ThetaType -> SDoc ppr_decl_context [] = empty ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>") +ppr_decl_class_context :: ClassContext -> SDoc +ppr_decl_class_context [] = empty +ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>") + pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files pprIfaceTheta [] = empty -pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) +pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta])) + +-- ZZ - not sure who uses this - i.e. whether IParams really show up or not +-- (it's not used to print normal value signatures) +pprIfacePred :: PredType -> SDoc +pprIfacePred (Class clas tys) = pprConstraint clas tys +pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty + +pprIfaceClasses :: ClassContext -> SDoc +pprIfaceClasses [] = empty +pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) \end{code} %************************************************************************