-\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 IdSet -- Set of Ids actually spat out
-
-ifaceBinds hdl needed_ids final_ids binds
- = mapIO (printForIface hdl) (bagToList pretties) >>
- hPutStr hdl "\n" >>
- return emitted
- 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, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet
- -- Reverse so that later things will
- -- provoke earlier ones to be emitted
- go needed [] pretties emitted
- | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
- (sep (map ppr (varSetElems needed)))
- (pretties, emitted)
- | otherwise = (pretties, emitted)
-
- go needed (NonRec id rhs : binds) pretties emitted
- = case ifaceId get_idinfo needed False id rhs of
- Nothing -> go needed binds pretties emitted
- Just (pretty, extras) -> let
- needed' = (needed `unionVarSet` extras) `delVarSet` id
- -- 'extras' can include the Id itself via a rule
- emitted' = emitted `extendVarSet` id
- in
- go needed' binds (pretty `consBag` pretties) emitted'
-
- -- 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 emitted
- = go needed' binds pretties' emitted'
- where
- (new_pretties, new_emitted, extras) = go_rec needed pairs
- pretties' = new_pretties `unionBags` pretties
- needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
- emitted' = emitted `unionVarSet` new_emitted
-
- go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
- go_rec needed pairs
- | null pretties = (emptyBag, emptyVarSet, emptyVarSet)
- | otherwise = (more_pretties `unionBags` listToBag pretties,
- more_emitted `unionVarSet` mkVarSet emitted,
- more_extras `unionVarSet` extras)
- where
- maybes = map do_one pairs
- emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
- reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
- (pretties, extras_s) = unzip (catMaybes maybes)
- extras = unionVarSets extras_s
- (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs
-
- do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Random small things}
-%* *
-%************************************************************************
-
-\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))
-
-for_iface_name name = isLocallyDefined name &&
- not (isWiredInName name)
-
-upp_tycon tycon = ifaceTyCon tycon
-upp_class clas = ifaceClass clas
-\end{code}
-
-
-\begin{code}
-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
- 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 (MarkedUnboxed _ _) = ptext SLIT("! ! ")
- ppr_strict_mark MarkedStrict = ptext SLIT("! ")
-
- 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,
- pprFundeps clas_fds,
- pp_ops,
- semi
- ]
- where
- (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
-
- pp_ops | null op_stuff = empty
- | otherwise = hsep [ptext SLIT("where"),
- braces (hsep (punctuate semi (map ppr_classop op_stuff)))
- ]
-
- ppr_classop (sel_id, dm_id, explicit_dm)
- = ASSERT( sel_tyvars == clas_tyvars)
- hsep [ppr (getOccName sel_id),
- if explicit_dm 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 [] = empty
-pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
-\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}
-upp_avail :: AvailInfo -> SDoc
-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{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}
-lt_avail :: AvailInfo -> AvailInfo -> Bool
-
-a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
-
-lt_name :: Name -> Name -> Bool
-n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
-
-lt_lexical :: NamedThing a => a -> a -> Bool
-lt_lexical a1 a2 = getName a1 `lt_name` getName a2
-
-lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
-lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
-
-sort_versions vs = sortLt lt_vers vs
-
-lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
-lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
-\end{code}
-
-
-\begin{code}
-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}