X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMkIface.lhs;h=dbc8f08c97448f0e94e3d8a39e5d917fe7c47b44;hb=8295d9ca0f3e72e545b35c43a4a2e1e4ec582fb6;hp=8083b8d89145da3c1836d56eeb28d7b671c8fb92;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 8083b8d..dbc8f08 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -1,74 +1,72 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[MkIface]{Print an interface for a module} \begin{code} -#include "HsVersions.h" - module MkIface ( startIface, endIface, - ifaceUsages, - ifaceVersions, - ifaceExportList, - ifaceFixities, - ifaceInstanceModules, - ifaceDecls, - ifaceInstances, - ifacePragmas + ifaceMain, + ifaceDecls ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" + +import IO ( Handle, hPutStr, openFile, + hClose, hPutStrLn, IOMode(..) ) -import Bag ( emptyBag, snocBag, bagToList ) -import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) -import CmdLineOpts ( opt_ProduceHi ) -import FieldLabel ( FieldLabel{-instance NamedThing-} ) -import FiniteMap ( fmToList ) import HsSyn -import Id ( idType, dataConRawArgTys, dataConFieldLabels, - dataConStrictMarks, StrictnessMark(..), - GenId{-instance NamedThing/Outputable-} +import RdrHsSyn ( RdrName(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..), + StrictnessMark(..) ) -import Name ( nameOrigName, origName, nameOf, - exportFlagOn, nameExportFlag, ExportFlag(..), - ltLexical, isExported, getExportFlag, - isLexSym, isLocallyDefined, - RdrName(..){-instance Outputable-}, - Name{-instance NamedThing-} - ) -import ParseUtils ( UsagesMap(..), VersionsMap(..) ) -import PprEnv -- not sure how much... -import PprStyle ( PprStyle(..) ) -import PprType -- most of it (??) -import Pretty ( prettyToUn ) -import Unpretty -- ditto -import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) -import TcModule ( TcIfaceInfo(..) ) +import RnMonad +import RnEnv ( availName, ifaceFlavour ) + import TcInstUtil ( InstInfo(..) ) -import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon ) -import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} ) - -uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util -ppr_ty ty = prettyToUn (pprType PprInterface ty) -ppr_tyvar tv = prettyToUn (ppr PprInterface tv) -ppr_name n - = let - on = origName n - s = nameOf on - pp = prettyToUn (ppr PprInterface on) - in - (if isLexSym s then uppParens else id) pp -{-OLD: -ppr_unq_name n - = let - on = origName n - s = nameOf on - pp = uppPStr s - in - (if isLexSym s then uppParens else id) pp --} +import WorkWrap ( getWorkerIdAndCons ) + +import CmdLineOpts +import Id ( Id, idType, idInfo, omitIfaceSigForId, + getIdSpecialisation + ) +import Var ( isId ) +import VarSet +import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks ) +import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo, + arityInfo, ppArityInfo, + strictnessInfo, ppStrictnessInfo, + cafInfo, ppCafInfo, + workerExists, isBottomingStrictness + ) +import CoreSyn ( CoreExpr, CoreBind, Bind(..) ) +import CoreUtils ( exprSomeFreeVars ) +import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), + Unfolding, okToUnfoldInHiFile ) +import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, + OccName, pprOccName, pprModule, isExported, moduleString, + Name, NamedThing(..) + ) +import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, + tyConTheta, tyConTyVars, tyConDataCons + ) +import Class ( Class, classBigSig ) +import SpecEnv ( specEnvToList ) +import FieldLabel ( fieldLabelName, fieldLabelType ) +import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, + Type, ThetaType + ) + +import PprType +import PprCore ( pprIfaceUnfolding ) + +import Bag ( bagToList, isEmptyBag ) +import Maybes ( catMaybes, maybeToBool ) +import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap ) +import UniqFM ( lookupUFM, listToUFM ) +import UniqSet ( uniqSetToList ) +import Util ( sortLt, mapAccumL ) +import Outputable \end{code} We have a function @startIface@ to open the output file and put @@ -82,356 +80,549 @@ to the handle provided by @startIface@. \begin{code} startIface :: Module -> IO (Maybe Handle) -- Nothing <=> don't do an interface -endIface :: Maybe Handle -> IO () -ifaceUsages - :: Maybe Handle - -> UsagesMap - -> IO () -ifaceVersions - :: Maybe Handle - -> VersionsMap - -> IO () -ifaceExportList - :: Maybe Handle - -> RenamedHsModule - -> IO () -ifaceFixities - :: Maybe Handle - -> RenamedHsModule - -> IO () -ifaceInstanceModules - :: Maybe Handle - -> [Module] - -> IO () -ifaceDecls :: Maybe Handle - -> TcIfaceInfo -- info produced by typechecker, for interfaces - -> IO () -ifaceInstances - :: Maybe Handle - -> TcIfaceInfo -- as above - -> IO () -ifacePragmas - :: Maybe Handle + +ifaceMain :: Maybe Handle + -> InterfaceDetails -> IO () -ifacePragmas = panic "ifacePragmas" -- stub + + +ifaceDecls :: Maybe Handle + -> [TyCon] -> [Class] + -> Bag InstInfo + -> [Id] -- Ids used at code-gen time; they have better pragma info! + -> [CoreBind] -- In dependency order, later depend on earlier + -> IO () + +endIface :: Maybe Handle -> IO () \end{code} \begin{code} startIface mod = case opt_ProduceHi of Nothing -> return Nothing -- not producing any .hi file - Just fn -> - openFile fn WriteMode >>= \ if_hdl -> - hPutStr if_hdl ("interface "++ _UNPK_ mod) >> + Just fn -> do + if_hdl <- openFile fn WriteMode + hPutStr if_hdl ("__interface " ++ moduleString mod ++ ' ':show (opt_HiVersion :: Int)) + hPutStrLn if_hdl " where" return (Just if_hdl) endIface Nothing = return () endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \end{code} -\begin{code} -ifaceUsages Nothing{-no iface handle-} _ = return () -ifaceUsages (Just if_hdl) usages - | null usages_list - = return () +\begin{code} +ifaceMain Nothing iface_stuff = return () +ifaceMain (Just if_hdl) + (import_usages, ExportEnv avails fixities, instance_modules) + = do + ifaceImports if_hdl import_usages + ifaceInstanceModules if_hdl instance_modules + ifaceExports if_hdl avails + ifaceFixities if_hdl fixities + return () + +ifaceDecls Nothing tycons classes inst_info final_ids simplified = return () +ifaceDecls (Just hdl) + tycons classes + inst_infos + final_ids binds + | null_decls = return () + -- You could have a module with just (re-)exports/instances in it | otherwise - = hPutStr if_hdl "\n__usages__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) + = ifaceClasses hdl classes >> + ifaceInstances hdl inst_infos >>= \ needed_ids -> + ifaceTyCons hdl tycons >> + ifaceBinds hdl needed_ids final_ids binds >> + return () where - usages_list = fmToList usages - - upp_uses (m, (mv, versions)) - = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), - upp_versions (fmToList versions), uppSemi] - - upp_versions nvs - = uppIntersperse uppSP [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ] + null_decls = null binds && + null tycons && + null classes && + isEmptyBag inst_infos \end{code} \begin{code} -ifaceVersions Nothing{-no iface handle-} _ = return () - -ifaceVersions (Just if_hdl) version_info - | null version_list - = return () - | otherwise - = hPutStr if_hdl "\n__versions__\n" >> - hPutStr if_hdl (uppShow 0 (upp_versions version_list)) +ifaceImports if_hdl import_usages + = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - version_list = fmToList version_info + upp_uses (m, hif, mv, whats_imported) + = ptext SLIT("import ") <> + hsep [pprModule m, pp_hif hif, int mv, dcolon, + upp_import_versions whats_imported + ] <> semi + + -- Importing the whole module is indicated by an empty list + upp_import_versions Everything = empty + + -- For imported versions we do print the version number + upp_import_versions (Specifically nvs) + = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] + +ifaceInstanceModules if_hdl [] = return () +ifaceInstanceModules if_hdl imods + = let sorted = sortLt (<) imods + lines = map (\m -> ptext SLIT("__instimport ") <> pprModule m <> + ptext SLIT(" ;")) sorted + in + printForIface if_hdl (vcat lines) >> + hPutStr if_hdl "\n" + +ifaceExports if_hdl [] = return () +ifaceExports if_hdl avails + = hPutCol if_hdl do_one_module (fmToList export_fm) + where + -- Sort them into groups by module + export_fm :: FiniteMap Module [AvailInfo] + export_fm = foldr insert emptyFM avails + + insert NotAvailable efm = efm + insert avail efm = addToFM_C (++) efm mod [avail] + where + mod = nameModule (availName avail) + + -- Print one module's worth of stuff + do_one_module :: (Module, [AvailInfo]) -> SDoc + do_one_module (mod_name, avails@(avail1:_)) + = ptext SLIT("__export ") <> + hsep [pp_hif (ifaceFlavour (availName avail1)), + pprModule mod_name, + hsep (map upp_avail (sortLt lt_avail avails)) + ] <> semi + +-- The "!" indicates that the exported things came from a hi-boot interface +pp_hif HiFile = empty +pp_hif HiBootFile = char '!' + +ifaceFixities if_hdl [] = return () +ifaceFixities if_hdl fixities + = hPutCol if_hdl upp_fixity fixities +\end{code} - upp_versions nvs - = uppAboves [ (if isLexSym n then uppParens else id) (uppPStr n) | (n,v) <- nvs ] -\end{code} +%************************************************************************ +%* * +\subsection{Instance declarations} +%* * +%************************************************************************ -\begin{code} -ifaceInstanceModules Nothing{-no iface handle-} _ = return () -ifaceInstanceModules (Just _) [] = return () -ifaceInstanceModules (Just if_hdl) imods - = hPutStr if_hdl "\n__instance_modules__\n" >> - hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) +\begin{code} +ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns +ifaceInstances if_hdl inst_infos + | null togo_insts = return emptyVarSet + | otherwise = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >> + return needed_ids + where + togo_insts = filter is_togo_inst (bagToList inst_infos) + needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts] + is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id + + ------- + lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _) + (InstInfo _ _ _ _ dfun_id2 _ _ _) + = getOccName dfun_id1 < getOccName dfun_id2 + -- The dfuns are assigned names df1, df2, etc, in order of original textual + -- occurrence, and this makes as good a sort order as any + + ------- + pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _) + = let + -- The deNoteType is very important. It removes all type + -- synonyms from the instance type in interface files. + -- That in turn makes sure that when reading in instance decls + -- from interface files that the 'gating' mechanism works properly. + -- Otherwise you could have + -- type Tibble = T Int + -- 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)) + renumbered_ty = tidyTopType forall_ty + in + hcat [ptext SLIT("instance "), pprType renumbered_ty, + ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] \end{code} -Export list: grab the Names of things that are marked Exported, sort -(so the interface file doesn't ``wobble'' from one compilation to the -next...), and print. Note that the ``module'' now contains all the -imported things that we are dealing with, thus including any entities -that we are re-exporting from somewhere else. -\begin{code} -ifaceExportList Nothing{-no iface handle-} _ = return () - -ifaceExportList (Just if_hdl) - (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _) - = let - name_flag_pairs :: Bag (Name, ExportFlag) - name_flag_pairs - = foldr from_ty - (foldr from_cls - (foldr from_sig - (from_binds binds emptyBag{-init accum-}) - sigs) - classdecls) - typedecls - - sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs) - - in - hPutStr if_hdl "\n__exports__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs))) - where - from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n - from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n - from_ty (TySynonym n _ _ _) acc = maybe_add acc n - from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n +%************************************************************************ +%* * +\subsection{Printing values} +%* * +%************************************************************************ - from_sig (Sig n _ _ _) acc = maybe_add acc n +\begin{code} +ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added + -- by the STG passes. Sigh + + -> IdSet -- Set of 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 + -> Bool -- True <=> recursive, so don't print unfolding + -> Id + -> CoreExpr -- The Id's right hand side + -> Maybe (SDoc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids + +ifaceId get_idinfo needed_ids is_rec id rhs + | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] + (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted + = Nothing -- Well, that was easy! + +ifaceId get_idinfo needed_ids is_rec id rhs + = Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids) + where + idinfo = get_idinfo id + inline_pragma = inlinePragInfo idinfo + + ty_pretty = pprType (idType id) + sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty] + + prag_pretty + | opt_OmitInterfacePragmas = empty + | otherwise = hsep [ptext SLIT("{-##"), + arity_pretty, + caf_pretty, + strict_pretty, + unfold_pretty, + spec_pretty, + ptext SLIT("##-}")] + + ------------ Arity -------------- + arity_pretty = ppArityInfo (arityInfo idinfo) + + ------------ Caf Info -------------- + caf_pretty = ppCafInfo (cafInfo idinfo) + + ------------ Strictness -------------- + strict_info = strictnessInfo idinfo + has_worker = workerExists strict_info + bottoming_fn = isBottomingStrictness strict_info + strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty + + wrkr_pretty | not has_worker = empty + | null con_list = ppr work_id + | otherwise = ppr work_id <+> + braces (hsep (map ppr con_list)) + + (work_id, wrapper_cons) = getWorkerIdAndCons id rhs + con_list = uniqSetToList wrapper_cons + + ------------ Unfolding -------------- + unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs + | otherwise = empty + + show_unfold = not has_worker && -- Not unnecessary + not bottoming_fn && -- Not necessary + unfolding_needed -- Not dangerous + + unfolding_needed = case inline_pragma of + IMustBeINLINEd -> definitely_ok_to_unfold + IWantToBeINLINEd -> definitely_ok_to_unfold + NoInlinePragInfo -> rhs_is_small + other -> False + + + unfold_herald = case inline_pragma of + NoInlinePragInfo -> ptext SLIT("__u") + other -> ppr inline_pragma + + rhs_is_small = case calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs of + UnfoldNever -> False -- Too big + other -> definitely_ok_to_unfold -- Small enough + + definitely_ok_to_unfold = okToUnfoldInHiFile rhs + + ------------ Specialisations -------------- + spec_list = specEnvToList (getIdSpecialisation id) + spec_pretty = hsep (map pp_spec spec_list) + pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("__P"), + if null tyvars then ptext SLIT("[ ]") + else brackets (interppSP tyvars), + -- The lexer interprets "[]" as a CONID. Sigh. + hsep (map pprParendType tys), + ptext SLIT("="), + pprIfaceUnfolding rhs + ] + + ------------ Extra free Ids -------------- + new_needed_ids = (needed_ids `minusVarSet` unitVarSet id) `unionVarSet` + extra_ids + + extra_ids | opt_OmitInterfacePragmas = emptyVarSet + | otherwise = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids + + worker_ids | has_worker = unitVarSet work_id + | otherwise = emptyVarSet + + spec_ids = foldr add emptyVarSet spec_list + where + add (_, _, rhs) = unionVarSet (find_fvs rhs) + + unfold_ids | show_unfold = find_fvs rhs + | otherwise = emptyVarSet + + find_fvs expr = free_vars + where + free_vars = exprSomeFreeVars interesting expr + interesting id = isId id && isLocallyDefined id && + not (omitIfaceSigForId id) +\end{code} - from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs) +\begin{code} +ifaceBinds :: Handle + -> IdSet -- These Ids are needed already + -> [Id] -- Ids used at code-gen time; they have better pragma info! + -> [CoreBind] -- In dependency order, later depend on earlier + -> IO () + +ifaceBinds hdl needed_ids final_ids binds + = mapIO (printForIface hdl) pretties >> + hPutStr hdl "\n" + where + final_id_map = listToUFM [(id,id) | id <- final_ids] + get_idinfo id = case lookupUFM final_id_map id of + Just id' -> idInfo id' + Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ + idInfo id + + pretties = go needed_ids (reverse binds) -- Reverse so that later things will + -- provoke earlier ones to be emitted + go needed [] = if not (isEmptyVarSet needed) then + pprTrace "ifaceBinds: free vars:" + (sep (map ppr (varSetElems needed))) $ + [] + else + [] + + go needed (NonRec id rhs : binds) + = case ifaceId get_idinfo needed False id rhs of + Nothing -> go needed binds + Just (pretty, needed') -> pretty : go needed' binds + + -- Recursive groups are a bit more of a pain. We may only need one to + -- start with, but it may call out the next one, and so on. So we + -- have to look for a fixed point. + go needed (Rec pairs : binds) + = pretties ++ go needed'' binds + where + (needed', pretties) = go_rec needed pairs + needed'' = needed' `minusVarSet` mkVarSet (map fst pairs) + -- Later ones may spuriously cause earlier ones to be "needed" again + + go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc]) + go_rec needed pairs + | null pretties = (needed, []) + | otherwise = (final_needed, more_pretties ++ pretties) + where + reduced_pairs = [pair | (pair,Nothing) <- pairs `zip` maybes] + pretties = catMaybes maybes + (needed', maybes) = mapAccumL do_one needed pairs + (final_needed, more_pretties) = go_rec needed' reduced_pairs + + do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of + Nothing -> (needed, Nothing) + Just (pretty, needed') -> (needed', Just pretty) +\end{code} - -------------- - maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag) - maybe_add acc rn - | exportFlagOn ef = acc `snocBag` (n, ef) - | otherwise = acc - where - n = getName rn - ef = nameExportFlag n +%************************************************************************ +%* * +\subsection{Random small things} +%* * +%************************************************************************ - -------------- - maybe_add_list acc [] = acc - maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n +\begin{code} +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)) - -------------- - lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2 +for_iface_name name = isLocallyDefined name && + not (isWiredInName name) - -------------- - upp_pair (n, ef) - = uppBeside (ppr_name n) (upp_export ef) - where - upp_export ExportAll = uppPStr SLIT("(..)") - upp_export ExportAbs = uppNil +upp_tycon tycon = ifaceTyCon tycon +upp_class clas = ifaceClass clas \end{code} + \begin{code} -ifaceFixities Nothing{-no iface handle-} _ = return () - -ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) - = let - local_fixities = filter from_here fixities - in - if null local_fixities then - return () - else - hPutStr if_hdl "\n__fixities__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities))) +ifaceTyCon :: TyCon -> SDoc +ifaceTyCon tycon + | isSynTyCon tycon + = hsep [ ptext SLIT("type"), + ppr (getName tycon), + pprTyVarBndrs tyvars, + ptext SLIT("="), + ppr ty, + semi + ] + where + (tyvars, ty) = getSynTyConDefn tycon + +ifaceTyCon tycon + | isAlgTyCon tycon + = hsep [ ptext keyword, + ppr_decl_context (tyConTheta tycon), + ppr (getName tycon), + pprTyVarBndrs (tyConTyVars tycon), + ptext SLIT("="), + hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))), + semi + ] where - from_here (InfixL v _) = isLocallyDefined v - from_here (InfixR v _) = isLocallyDefined v - from_here (InfixN v _) = isLocallyDefined v + keyword | isNewTyCon tycon = SLIT("newtype") + | otherwise = SLIT("data") + + tyvars = tyConTyVars tycon + + ppr_con data_con + | null field_labels + = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) + hsep [ ppr_ex ex_tyvars ex_theta, + ppr name, + hsep (map ppr_arg_ty (strict_marks `zip` arg_tys)) + ] + + | otherwise + = hsep [ ppr_ex ex_tyvars ex_theta, + ppr name, + braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) + ] + where + (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con + field_labels = dataConFieldLabels data_con + strict_marks = dataConStrictMarks data_con + name = getName data_con + + 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("=>") + + ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty + + ppr_strict_mark NotMarkedStrict = empty + ppr_strict_mark MarkedStrict = ptext SLIT("! ") + -- The extra space helps the lexical analyser that lexes + -- interface files; it doesn't make the rigid operator/identifier + -- distinction, so "!a" is a valid identifier so far as it is concerned + + ppr_field (strict_mark, field_label) + = hsep [ ppr (fieldLabelName field_label), + dcolon, + ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label) + ] + +ifaceTyCon tycon + = pprPanic "pprIfaceTyDecl" (ppr tycon) + +ifaceClass clas + = hsep [ptext SLIT("class"), + ppr_decl_context sc_theta, + ppr clas, -- Print the name + pprTyVarBndrs clas_tyvars, + pp_ops, + semi + ] + where + (clas_tyvars, sc_theta, _, sel_ids, defms) = classBigSig clas + + pp_ops | null sel_ids = empty + | otherwise = hsep [ptext SLIT("where"), + braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms))) + ] + + ppr_classop sel_id maybe_defm + = ASSERT( sel_tyvars == clas_tyvars) + hsep [ppr (getOccName sel_id), + if maybeToBool maybe_defm then equals else empty, + dcolon, + ppr op_ty + ] + where + (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) + +ppr_decl_context :: ThetaType -> SDoc +ppr_decl_context [] = empty +ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>") + +pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files +pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) \end{code} -\begin{code} -ifaceDecls Nothing{-no iface handle-} _ = return () - -ifaceDecls (Just if_hdl) (vals, tycons, classes, _) - = ASSERT(all isLocallyDefined vals) - ASSERT(all isLocallyDefined tycons) - ASSERT(all isLocallyDefined classes) - let - sorted_classes = sortLt ltLexical classes - sorted_tycons = sortLt ltLexical tycons - sorted_vals = sortLt ltLexical vals - in - if (null sorted_classes && null sorted_tycons && null sorted_vals) then - -- You could have a module with just instances in it - return () - else - hPutStr if_hdl "\n__declarations__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves [ - uppAboves (map ppr_class sorted_classes), - uppAboves (map ppr_tycon sorted_tycons), - uppAboves [ppr_val v (idType v) | v <- sorted_vals]])) -\end{code} +%************************************************************************ +%* * +\subsection{Random small things} +%* * +%************************************************************************ + +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 \begin{code} -ifaceInstances Nothing{-no iface handle-} _ = return () - -ifaceInstances (Just if_hdl) (_, _, _, insts) - = let - togo_insts = filter is_togo_inst (bagToList insts) - - sorted_insts = sortLt lt_inst togo_insts - in - if null togo_insts then - return () - else - hPutStr if_hdl "\n__instances__\n" >> - hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts))) - where - is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) - = from_here -- && ... - - ------- - lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _) - (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _) - = let - tycon1 = fst (getAppTyCon ty1) - tycon2 = fst (getAppTyCon ty2) - in - case (origName clas1 `cmp` origName clas2) of - LT_ -> True - GT_ -> False - EQ_ -> origName tycon1 < origName tycon2 - - ------- - pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _) - = let - forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) - renumbered_ty = initNmbr (nmbrType forall_ty) - in - uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi] +upp_avail :: AvailInfo -> SDoc +upp_avail NotAvailable = empty +upp_avail (Avail name) = pprOccName (getOccName name) +upp_avail (AvailTC name []) = empty +upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns'] + where + bang | name `elem` ns = empty + | otherwise = char '|' + ns' = filter (/= name) ns + +upp_export :: [Name] -> SDoc +upp_export [] = empty +upp_export names = braces (hsep (map (pprOccName . getOccName) names)) + +upp_fixity :: (Name, Fixity) -> SDoc +upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi] + -- Dummy version number! + +ppr_unqual_name :: NamedThing a => a -> SDoc -- Just its occurrence name +ppr_unqual_name name = pprOccName (getOccName name) \end{code} + %************************************************************************ -%* * -\subsection{Printing tycons, classes, ...} -%* * +%* * +\subsection{Comparisons +%* * %************************************************************************ + + +The various sorts above simply prevent unnecessary "wobbling" when +things change that don't have to. We therefore compare lexically, not +by unique \begin{code} -ppr_class :: Class -> Unpretty - -ppr_class c - = --pprTrace "ppr_class:" (ppr PprDebug c) $ - case (initNmbr (nmbrClass c)) of { -- renumber it! - Class _ n tyvar super_classes sdsels ops sels defms insts links -> - - uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes, - ppr_name n, ppr_tyvar tyvar, - if null ops - then uppSemi - else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]] - } - where - ppr_theta :: TyVar -> [Class] -> Unpretty +lt_avail :: AvailInfo -> AvailInfo -> Bool - ppr_theta tv [] = uppNil - ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) - ppr_theta tv super_classes - = uppBesides [uppLparen, - uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes), - uppStr ") =>"] +a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 - ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv] +lt_name :: Name -> Name -> Bool +n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2 - ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty -\end{code} +lt_lexical :: NamedThing a => a -> a -> Bool +lt_lexical a1 a2 = getName a1 `lt_name` getName a2 -\begin{code} -ppr_val v ty -- renumber the type first! - = --pprTrace "ppr_val:" (ppr PprDebug v) $ - pp_sig v (initNmbr (nmbrType ty)) +lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool +lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2 + +sort_versions vs = sortLt lt_vers vs -pp_sig op ty - = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi] +lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool +lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2 \end{code} + \begin{code} -ppr_tycon tycon - = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $ - ppr_tc (initNmbr (nmbrTyCon tycon)) - ------------------------- -ppr_tc (PrimTyCon _ n _ _) - = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ] - -ppr_tc FunTyCon - = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ] - -ppr_tc (TupleTyCon _ n _) - = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ] - -ppr_tc (SynTyCon _ n _ _ tvs expand) - = let - pp_tyvars = map ppr_tyvar tvs - in - uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars, - uppPStr SLIT(" = "), ppr_ty expand, uppSemi] - -ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) - = uppCat [pp_data_or_new, - ppr_context ctxt, - ppr_name n, - uppIntersperse uppSP (map ppr_tyvar tvs), - uppEquals, pp_condecls, - uppSemi] - -- NB: we do not print deriving info in interfaces - where - pp_data_or_new = case data_or_new of - DataType -> uppPStr SLIT("data") - NewType -> uppPStr SLIT("newtype") - - ppr_context [] = uppNil - ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] - ppr_context cs - = uppBesides[uppLparen, - uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], - uppRparen, uppPStr SLIT(" =>")] - - pp_condecls - = let - (c:cs) = cons - in - uppCat ((ppr_con c) : (map ppr_next_con cs)) - - ppr_next_con con = uppCat [uppChar '|', ppr_con con] - - ppr_con con - = let - con_arg_tys = dataConRawArgTys con - labels = dataConFieldLabels con -- none if not a record - strict_marks = dataConStrictMarks con - in - uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys] - - ppr_fields labels strict_marks con_arg_tys - = if null labels then -- not a record thingy - uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys) - else - uppCat [ uppChar '{', - uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys), - uppChar '}' ] - - ppr_bang_ty b t - = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }) - (prettyToUn (pprParendType PprInterface t)) - - ppr_field l b t - = uppBesides [ppr_name l, uppPStr SLIT(" :: "), - case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }, - ppr_ty t] +hPutCol :: Handle + -> (a -> SDoc) + -> [a] + -> IO () +hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs + +mapIO :: (a -> IO b) -> [a] -> IO () +mapIO f [] = return () +mapIO f (x:xs) = f x >> mapIO f xs \end{code}