-ppr_hs_info (HsInline act) = ptext SLIT("Inline:") <+> ppr act
-ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
-ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
-ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
-ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
-\end{code}
-
-
-%************************************************************************
-%* *
- Converting things to their Iface equivalents
-%* *
-%************************************************************************
-
-
-\begin{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,
- ifSigs = map toIfaceClassOp op_stuff,
- ifRec = boolToRecFlag (isRecursiveTyCon tycon),
- ifVrcs = tyConArgVrcs tycon }
- where
- (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
- tycon = classTyCon clas
-
- 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 getOccName tvs1, map getOccName tvs2)
-
-tyThingToIfaceDecl ext (ATyCon tycon)
- | isSynTyCon tycon
- = IfaceSyn { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs tyvars,
- ifVrcs = tyConArgVrcs tycon,
- ifSynRhs = toIfaceType ext syn_ty }
-
- | isAlgTyCon tycon
- = IfaceData { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs tyvars,
- ifCtxt = toIfaceContext ext (tyConStupidTheta tycon),
- ifCons = ifaceConDecls (algTyConRhs tycon),
- ifRec = boolToRecFlag (isRecursiveTyCon tycon),
- ifVrcs = tyConArgVrcs tycon,
- ifGeneric = tyConHasGenerics 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,
- ifGeneric = False,
- ifRec = NonRecursive,
- ifVrcs = tyConArgVrcs tycon }
-
- | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
- where
- tyvars = tyConTyVars tycon
- syn_ty = synTyConRhs tycon
-
- ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- 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
- | isVanillaDataCon data_con
- = IfVanillaCon {ifConOcc = getOccName (dataConName data_con),
- ifConInfix = dataConIsInfix data_con,
- ifConArgTys = map (toIfaceType ext) arg_tys,
- ifConStricts = strict_marks,
- ifConFields = map getOccName field_labels }
- | otherwise
- = IfGadtCon { ifConOcc = getOccName (dataConName data_con),
- ifConTyVars = toIfaceTvBndrs tyvars,
- ifConCtxt = toIfaceContext ext theta,
- ifConArgTys = map (toIfaceType ext) arg_tys,
- ifConResTys = map (toIfaceType ext) res_tys,
- ifConStricts = strict_marks }
- where
- (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con
- field_labels = dataConFieldLabels data_con
- strict_marks = dataConStrictMarks data_con
-
-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
- 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 }
-
----------------------
-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) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
-toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
-toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
-
----------------------
-toIfaceNote ext (SCC cc) = IfaceSCC cc
-toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
-toIfaceNote ext InlineMe = IfaceInlineMe
-toIfaceNote ext (CoreNote s) = IfaceCoreNote s
-
----------------------
-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]
-
----------------------
-toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
-
----------------------
-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 (nameOccName name)
- where
- name = idName v