- from_val rn acc
- | fun_looking rn && exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- ef = export_fn n -- NB: using the export fn!
- n = getName rn
- on = origName "from_val" n
-
- -- fun_looking: must avoid class ops and data constructors
- -- and record fieldnames
- fun_looking (RnName _) = True
- fun_looking (WiredInId i) = not (isDataCon i)
- fun_looking _ = False
-
- from_tc rn acc
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- ef = export_fn n -- NB: using the export fn!
- n = getName rn
- on = origName "from_tc" n
-
- from_dotdot is_valish (n,ef) acc
- | is_valish && isLexCon str = acc
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- on = origName "from_dotdot" n
- (OrigName _ str) = on
-
- from_wired is_val_ish rn acc
- | is_val_ish && not (fun_looking rn)
- = acc -- these things don't cause export-ery
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- n = getName rn
- ef = export_fn n
- on = origName "from_wired" n
-
- --------------
- lexical_lt (n1,_) (n2,_) = n1 < n2
-
- --------------
- upp_pair (OrigName m n, ef)
- = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
- where
- upp_export ExportAll = uppPStr SLIT("(..)")
- upp_export ExportAbs = uppNil
+ 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)