{-# LANGUAGE CPP #-}
module ToIface
(
toIfaceTvBndr
, toIfaceTvBndrs
, toIfaceIdBndr
, toIfaceBndr
, toIfaceForAllBndr
, toIfaceTyVarBinders
, toIfaceTyVar
, toIfaceType, toIfaceTypeX
, toIfaceKind
, toIfaceTcArgs
, toIfaceTyCon
, toIfaceTyCon_name
, toIfaceTyLit
, tidyToIfaceType
, tidyToIfaceContext
, tidyToIfaceTcArgs
, toIfaceCoercion, toIfaceCoercionX
, patSynToIfaceDecl
, toIfaceExpr
, toIfaceBang
, toIfaceSrcBang
, toIfaceLetBndr
, toIfaceIdDetails
, toIfaceIdInfo
, toIfUnfolding
, toIfaceOneShot
, toIfaceTickish
, toIfaceBind
, toIfaceAlt
, toIfaceCon
, toIfaceApp
, toIfaceVar
) where
#include "HsVersions.h"
import GhcPrelude
import IfaceSyn
import DataCon
import Id
import IdInfo
import CoreSyn
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )
import TysWiredIn ( heqTyCon )
import MkId ( noinlineIdName )
import PrelNames
import Name
import BasicTypes
import Type
import PatSyn
import Outputable
import FastString
import Util
import Var
import VarEnv
import VarSet
import TyCoRep
import Demand ( isTopSig )
import Data.Maybe ( catMaybes )
toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
, toIfaceTypeX fr (tyVarKind tyvar)
)
toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
toIfaceTvBndrs = map toIfaceTvBndr
toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
| isId var = IfaceIdBndr (toIfaceIdBndr var)
| otherwise = IfaceTvBndr (toIfaceTvBndr var)
toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis
toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis
toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis]
toIfaceTyVarBinders = map toIfaceTyVarBinder
toIfaceKind :: Type -> IfaceType
toIfaceKind = toIfaceType
toIfaceType :: Type -> IfaceType
toIfaceType = toIfaceTypeX emptyVarSet
toIfaceTypeX :: VarSet -> Type -> IfaceType
toIfaceTypeX fr (TyVarTy tv)
| tv `elemVarSet` fr = IfaceFreeTyVar tv
| otherwise = IfaceTyVar (toIfaceTyVar tv)
toIfaceTypeX fr (AppTy t1 t2) = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
(toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy t1 t2)
| isPredTy t1 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
| otherwise = IfaceFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)
toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)
toIfaceTypeX fr (TyConApp tc tys)
| Just sort <- tyConTuple_maybe tc
, n_tys == arity
= IfaceTupleTy sort IsNotPromoted (toIfaceTcArgsX fr tc tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, n_tys == 2*arity
= IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
| tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
, (k1:k2:_) <- tys
= let info = IfaceTyConInfo IsNotPromoted sort
sort | k1 `eqType` k2 = IfaceEqualityTyCon
| otherwise = IfaceNormalTyCon
in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
| otherwise
= IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys)
where
arity = tyConArity tc
n_tys = length tys
toIfaceTyVar :: TyVar -> FastString
toIfaceTyVar = occNameFS . getOccName
toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
toIfaceForAllBndrX :: VarSet -> TyVarBinder -> IfaceForAllBndr
toIfaceForAllBndrX fr (TvBndr v vis) = TvBndr (toIfaceTvBndrX fr v) vis
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
= IfaceTyCon tc_name info
where
tc_name = tyConName tc
info = IfaceTyConInfo promoted sort
promoted | isPromotedDataCon tc = IsPromoted
| otherwise = IsNotPromoted
tupleSort :: TyCon -> Maybe IfaceTyConSort
tupleSort tc' =
case tyConTuple_maybe tc' of
Just UnboxedTuple -> let arity = tyConArity tc' `div` 2
in Just $ IfaceTupleTyCon arity UnboxedTuple
Just sort -> let arity = tyConArity tc'
in Just $ IfaceTupleTyCon arity sort
Nothing -> Nothing
sort
| Just tsort <- tupleSort tc = tsort
| Just dcon <- isPromotedDataCon_maybe tc
, let tc' = dataConTyCon dcon
, Just tsort <- tupleSort tc' = tsort
| isUnboxedSumTyCon tc
, Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)
| otherwise = IfaceNormalTyCon
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name n = IfaceTyCon n info
where info = IfaceTyConInfo IsNotPromoted IfaceNormalTyCon
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion = toIfaceCoercionX emptyVarSet
toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
toIfaceCoercionX fr co
= go co
where
go (Refl r ty) = IfaceReflCo r (toIfaceTypeX fr ty)
go (CoVarCo cv)
| cv `elemVarSet` fr = IfaceFreeCoVar cv
| otherwise = IfaceCoVarCo (toIfaceCoVar cv)
go (HoleCo h) = IfaceHoleCo (coHoleCoVar h)
go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2)
go (SymCo co) = IfaceSymCo (go co)
go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2)
go (NthCo _r d co) = IfaceNthCo d (go co)
go (LRCo lr co) = IfaceLRCo lr (go co)
go (InstCo co arg) = IfaceInstCo (go co) (go arg)
go (CoherenceCo c1 c2) = IfaceCoherenceCo (go c1) (go c2)
go (KindCo c) = IfaceKindCo (go c)
go (SubCo co) = IfaceSubCo (go co)
go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs)
go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r
(toIfaceTypeX fr t1)
(toIfaceTypeX fr t2)
go (TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co)
| otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2)
go (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)
(toIfaceCoercionX fr' k)
(toIfaceCoercionX fr' co)
where
fr' = fr `delVarSet` tv
go_prov :: UnivCoProvenance -> IfaceUnivCoProv
go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv
go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
go_prov (PluginProv str) = IfacePluginProv str
toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs
toIfaceTcArgsX fr tc ty_args
= go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args
where
in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
go _ _ [] = ITC_Nil
go env ty ts
| Just ty' <- coreView ty
= go env ty' ts
go env (ForAllTy (TvBndr tv vis) res) (t:ts)
| isVisibleArgFlag vis = ITC_Vis t' ts'
| otherwise = ITC_Invis t' ts'
where
t' = toIfaceTypeX fr t
ts' = go (extendTvSubst env tv t) res ts
go env (FunTy _ res) (t:ts)
= ITC_Vis (toIfaceTypeX fr t) (go env res ts)
go env ty ts@(t1:ts1)
| not (isEmptyTCvSubst env)
= go (zapTCvSubst env) (substTy env ty) ts
| otherwise
=
WARN( True, ppr ty $$ ppr ts)
ITC_Vis (toIfaceTypeX fr t1) (go env ty ts1)
tidyToIfaceType :: TidyEnv -> Type -> IfaceType
tidyToIfaceType env ty = toIfaceType (tidyType env ty)
tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
patSynToIfaceDecl :: PatSyn -> IfaceDecl
patSynToIfaceDecl ps
= IfacePatSyn { ifName = getName $ ps
, ifPatMatcher = to_if_pr (patSynMatcher ps)
, ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
, ifPatIsInfix = patSynIsInfix ps
, ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs'
, ifPatExBndrs = map toIfaceForAllBndr ex_bndrs'
, ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
, ifPatReqCtxt = tidyToIfaceContext env2 req_theta
, ifPatArgs = map (tidyToIfaceType env2) args
, ifPatTy = tidyToIfaceType env2 rhs_ty
, ifFieldLabels = (patSynFieldLabels ps)
}
where
(_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
univ_bndrs = patSynUnivTyVarBinders ps
ex_bndrs = patSynExTyVarBinders ps
(env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs
(env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
toIfaceBang _ HsLazy = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
(toIfaceJoinInfo (isJoinId_maybe id))
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
toIfaceIdDetails (DFunId {}) = IfDFunId
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) =
let iface = case tc of
RecSelData ty_con -> Left (toIfaceTyCon ty_con)
RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)
in IfRecSelId iface n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
inline_hsinfo, unfold_hsinfo, levity_hsinfo] of
[] -> NoInfo
infos -> HasInfo infos
where
arity_info = arityInfo id_info
arity_hsinfo | arity_info == 0 = Nothing
| otherwise = Just (HsArity arity_info)
caf_info = cafInfo id_info
caf_hsinfo = case caf_info of
NoCafRefs -> Just HsNoCafRefs
_other -> Nothing
sig_info = strictnessInfo id_info
strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)
| otherwise = Nothing
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isStrongLoopBreaker (occInfo id_info)
inline_prag = inlinePragInfo id_info
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| otherwise = Just (HsInline inline_prag)
levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity
| otherwise = Nothing
toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
toIfaceJoinInfo Nothing = IfaceNotJoinPoint
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
, uf_src = src
, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
InlineStable
-> case guidance of
UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
-> IfInlineRule arity unsat_ok boring_ok if_rhs
_other -> IfCoreUnfold True if_rhs
InlineCompulsory -> IfCompulsory if_rhs
InlineRhs -> IfCoreUnfold False if_rhs
where
if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
toIfUnfolding _ (OtherCon {}) = Nothing
toIfUnfolding _ BootUnfolding = Nothing
toIfUnfolding _ NoUnfolding = Nothing
toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
| otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
toIfaceExpr (Tick t e)
| Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
| otherwise = toIfaceExpr e
toIfaceOneShot :: Id -> IfaceOneShot
toIfaceOneShot id | isId id
, OneShotLam <- oneShotInfo (idInfo id)
= IfaceOneShot
| otherwise
= IfaceNoOneShot
toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
toIfaceTickish (Breakpoint {}) = Nothing
toIfaceBind :: Bind Id -> IfaceBinding
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
toIfaceAlt :: (AltCon, [Var], CoreExpr)
-> (IfaceConAlt, [FastString], IfaceExpr)
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r)
toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
toIfaceCon (LitAlt l) = IfaceLitAlt l
toIfaceCon DEFAULT = IfaceDefault
toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
= case isDataConWorkId_maybe v of
Just dc | saturated
, Just tup_sort <- tyConTuple_maybe tc
-> IfaceTuple tup_sort tup_args
where
val_args = dropWhile isTypeArg as
saturated = val_args `lengthIs` idArity v
tup_args = map toIfaceExpr val_args
tc = dataConTyCon dc
_ -> mkIfaceApps (toIfaceVar v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
| isBootUnfolding (idUnfolding v)
= IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v))))
(IfaceExt name)
| isExternalName name = IfaceExt name
| otherwise = IfaceLcl (getOccFS name)
where name = idName v