module TcIface (
tcLookupImported_maybe,
importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
typecheckIfacesForMerging,
typecheckIfaceForInstantiate,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceExpr,
tcIfaceGlobal
) where
#include "HsVersions.h"
import GhcPrelude
import TcTypeNats(typeNatCoAxiomRules)
import IfaceSyn
import LoadIface
import IfaceEnv
import BuildTyCl
import TcRnMonad
import TcType
import Type
import Coercion
import CoAxiom
import TyCoRep
import HscTypes
import Annotations
import InstEnv
import FamInstEnv
import CoreSyn
import CoreUtils
import CoreUnfold
import CoreLint
import MkCore
import Id
import MkId
import IdInfo
import Class
import TyCon
import ConLike
import DataCon
import PrelNames
import TysWiredIn
import Literal
import Var
import VarSet
import Name
import NameEnv
import NameSet
import OccurAnal ( occurAnalyseExpr )
import Demand
import Module
import UniqFM
import UniqSupply
import Outputable
import Maybes
import SrcLoc
import DynFlags
import Util
import FastString
import BasicTypes hiding ( SuccessFlag(..) )
import ListSetOps
import GHC.Fingerprint
import qualified BooleanFormula as BF
import Data.List
import Control.Monad
import qualified Data.Map as Map
typecheckIface :: ModIface
-> IfG ModDetails
typecheckIface iface
= initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
{
ignore_prags <- goptM Opt_IgnoreInterfacePragmas
; names_w_things <- loadDecls ignore_prags (mi_decls iface)
; let type_env = mkNameEnv names_w_things
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface)
; exports <- ifaceExportNames (mi_exports iface)
; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
text "Type envt:" <+> ppr (map fst names_w_things)])
; return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_sigs = complete_sigs
}
}
isAbstractIfaceDecl :: IfaceDecl -> Bool
isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
isAbstractIfaceDecl _ = False
ifMaybeRoles :: IfaceDecl -> Maybe [Role]
ifMaybeRoles IfaceData { ifRoles = rs } = Just rs
ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs
ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs
ifMaybeRoles _ = Nothing
mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
mergeIfaceDecl d1 d2
| isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
| isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
| IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
, IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
= let ops = nameEnvElts $
plusNameEnv_C mergeIfaceClassOp
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
}
} `withRolesFrom` d2
| otherwise = d1 `withRolesFrom` d2
withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
d1 `withRolesFrom` d2
| Just roles1 <- ifMaybeRoles d1
, Just roles2 <- ifMaybeRoles d2
, not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)
= d1 { ifRoles = mergeRoles roles1 roles2 }
| otherwise = d1
where
mergeRoles roles1 roles2 = zipWith max roles1 roles2
isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True
isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True
isRepInjectiveIfaceDecl _ = False
mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
mergeIfaceClassOp _ op2 = op2
mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
typecheckIfacesForMerging mod ifaces tc_env_var =
initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
ignore_prags <- goptM Opt_IgnoreInterfacePragmas
let mk_decl_env decls
= mkOccEnv [ (getOccName decl, decl)
| decl <- decls
, case decl of
IfaceId { ifIdDetails = IfDFunId } -> False
_ -> True ]
decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
:: [OccEnv IfaceDecl]
decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
:: OccEnv IfaceDecl
names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
(occEnvElts decl_env))
let global_type_env = mkNameEnv names_w_things
writeMutVar tc_env_var global_type_env
details <- forM ifaces $ \iface -> do
type_env <- fixM $ \type_env -> do
setImplicitEnvM type_env $ do
decls <- loadDecls ignore_prags (mi_decls iface)
return (mkNameEnv decls)
setImplicitEnvM type_env $ do
insts <- mapM tcIfaceInst (mi_insts iface)
fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_sigs = complete_sigs
}
return (global_type_env, details)
typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
typecheckIfaceForInstantiate nsubst iface =
initIfaceLclWithSubst (mi_semantic_module iface)
(text "typecheckIfaceForInstantiate")
(mi_boot iface) nsubst $ do
ignore_prags <- goptM Opt_IgnoreInterfacePragmas
type_env <- fixM $ \type_env -> do
setImplicitEnvM type_env $ do
decls <- loadDecls ignore_prags (mi_decls iface)
return (mkNameEnv decls)
setImplicitEnvM type_env $ do
insts <- mapM tcIfaceInst (mi_insts iface)
fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_exports = exports
, md_complete_sigs = complete_sigs
}
tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
tcHiBootIface hsc_src mod
| HsBootFile <- hsc_src
= return NoSelfBoot
| otherwise
= do { traceIf (text "loadHiBootInterface" <+> ppr mod)
; mode <- getGhcMode
; if not (isOneShot mode)
then do { hpt <- getHpt
; case lookupHpt hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> mkSelfBootInfo (hm_iface info) (hm_details info)
_ -> return NoSelfBoot }
else do
{ read_result <- findAndReadIface
need (fst (splitModuleInsts mod)) mod
True
; case read_result of {
Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
; mkSelfBootInfo iface tc_iface } ;
Failed err ->
do { eps <- getEps
; case lookupUFM (eps_is_boot eps) (moduleName mod) of
Nothing -> return NoSelfBoot
Just (_, False) -> failWithTc moduleLoop
Just (_mod, True) -> failWithTc (elaborate err)
}}}}
where
need = text "Need the hi-boot interface for" <+> ppr mod
<+> text "to compare against the Real Thing"
moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
<+> text "depends on itself"
elaborate err = hang (text "Could not find hi-boot interface for" <+>
quotes (ppr mod) <> colon) 4 err
mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
mkSelfBootInfo iface mds
= do
let tcs = map ifName
. filter isIfaceTyCon
. map snd
$ mi_decls iface
return $ SelfBoot { sb_mds = mds
, sb_tcs = mkNameSet tcs }
where
isIfaceTyCon IfaceId{} = False
isIfaceTyCon IfaceData{} = True
isIfaceTyCon IfaceSynonym{} = True
isIfaceTyCon IfaceFamily{} = True
isIfaceTyCon IfaceClass{} = True
isIfaceTyCon IfaceAxiom{} = False
isIfaceTyCon IfacePatSyn{} = False
tcIfaceDecl :: Bool
-> IfaceDecl
-> IfL TyThing
tcIfaceDecl = tc_iface_decl Nothing
tc_iface_decl :: Maybe Class
-> Bool
-> IfaceDecl
-> IfL TyThing
tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
ifIdDetails = details, ifIdInfo = info})
= do { ty <- tcIfaceType iface_type
; details <- tcIdDetails ty details
; info <- tcIdInfo ignore_prags TopLevel name ty info
; return (AnId (mkGlobalId details name ty info)) }
tc_iface_decl _ _ (IfaceData {ifName = tc_name,
ifCType = cType,
ifBinders = binders,
ifResKind = res_kind,
ifRoles = roles,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifParent = mb_parent })
= bindIfaceTyConBinders_AT binders $ \ binders' -> do
{ res_kind' <- tcIfaceType res_kind
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tc_name mb_parent
; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
; return (mkAlgTyCon tc_name binders' res_kind'
roles cType stupid_theta
cons parent' gadt_syn) }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
tc_parent tc_name IfNoParent
= do { tc_rep_name <- newTyConRepName tc_name
; return (VanillaAlgTyCon tc_rep_name) }
tc_parent _ (IfDataInstance ax_name _ arg_tys)
= do { ax <- tcIfaceCoAxiom ax_name
; let fam_tc = coAxiomTyCon ax
ax_unbr = toUnbranchedAxiom ax
; lhs_tys <- tcIfaceTcArgs arg_tys
; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
ifRoles = roles,
ifSynRhs = rhs_ty,
ifBinders = binders,
ifResKind = res_kind })
= bindIfaceTyConBinders_AT binders $ \ binders' -> do
{ res_kind' <- tcIfaceType res_kind
; rhs <- forkM (mk_doc tc_name) $
tcIfaceType rhs_ty
; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
; return (ATyCon tycon) }
where
mk_doc n = text "Type synonym" <+> ppr n
tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
ifFamFlav = fam_flav,
ifBinders = binders,
ifResKind = res_kind,
ifResVar = res, ifFamInj = inj })
= bindIfaceTyConBinders_AT binders $ \ binders' -> do
{ res_kind' <- tcIfaceType res_kind
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav tc_name fam_flav
; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
; return (ATyCon tycon) }
where
mk_doc n = text "Type synonym" <+> ppr n
tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
tc_fam_flav tc_name IfaceDataFamilyTyCon
= do { tc_rep_name <- newTyConRepName tc_name
; return (DataFamilyTyCon tc_rep_name) }
tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
= do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
; return (ClosedSynFamilyTyCon ax) }
tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon
tc_fam_flav _ IfaceBuiltInSynFamTyCon
= pprPanic "tc_iface_decl"
(text "IfaceBuiltInSynFamTyCon in interface file")
tc_iface_decl _parent _ignore_prags
(IfaceClass {ifName = tc_name,
ifRoles = roles,
ifBinders = binders,
ifFDs = rdr_fds,
ifBody = IfAbstractClass})
= bindIfaceTyConBinders binders $ \ binders' -> do
{ fds <- mapM tc_fd rdr_fds
; cls <- buildClass tc_name binders' roles fds Nothing
; return (ATyCon (classTyCon cls)) }
tc_iface_decl _parent ignore_prags
(IfaceClass {ifName = tc_name,
ifRoles = roles,
ifBinders = binders,
ifFDs = rdr_fds,
ifBody = IfConcreteClass {
ifClassCtxt = rdr_ctxt,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ
}})
= bindIfaceTyConBinders binders $ \ binders' -> do
{ traceIf (text "tc-iface-class1" <+> ppr tc_name)
; ctxt <- mapM tc_sc rdr_ctxt
; traceIf (text "tc-iface-class2" <+> ppr tc_name)
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_name)
; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name)
; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
tc_sig :: IfaceClassOp -> IfL TcMethInfo
tc_sig (IfaceClassOp op_name rdr_ty dm)
= do { let doc = mk_op_doc op_name rdr_ty
; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
; dm' <- tc_dm doc dm
; return (op_name, op_ty, dm') }
tc_dm :: SDoc
-> Maybe (DefMethSpec IfaceType)
-> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
tc_dm _ Nothing = return Nothing
tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
tc_dm doc (Just (GenericDM ty))
= do {
; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
; return (Just (GenericDM (noSrcSpan, ty'))) }
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
mb_def <- case if_def of
Nothing -> return Nothing
Just def -> forkM (mk_at_doc tc) $
extendIfaceTyVarEnv (tyConTyVars tc) $
do { tc_def <- tcIfaceType def
; return (Just (tc_def, noSrcSpan)) }
return (ATI tc mb_def)
mk_sc_doc pred = text "Superclass" <+> ppr pred
mk_at_doc tc = text "Associated type" <+> ppr tc
mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
, ifAxBranches = branches, ifRole = role })
= do { tc_tycon <- tcIfaceTyCon tc
; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
$ tc_ax_branches branches
; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
, co_ax_name = tc_name
, co_ax_tc = tc_tycon
, co_ax_role = role
, co_ax_branches = manyBranches tc_branches
, co_ax_implicit = False }
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = name
, ifPatMatcher = if_matcher
, ifPatBuilder = if_builder
, ifPatIsInfix = is_infix
, ifPatUnivBndrs = univ_bndrs
, ifPatExBndrs = ex_bndrs
, ifPatProvCtxt = prov_ctxt
, ifPatReqCtxt = req_ctxt
, ifPatArgs = args
, ifPatTy = pat_ty
, ifFieldLabels = field_labels })
= do { traceIf (text "tc_iface_decl" <+> ppr name)
; matcher <- tc_pr if_matcher
; builder <- fmapMaybeM tc_pr if_builder
; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
{ bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
{ patsyn <- forkM (mk_doc name) $
do { prov_theta <- tcIfaceCtxt prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; arg_tys <- mapM tcIfaceType args
; return $ buildPatSyn name is_infix matcher builder
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
arg_tys pat_ty field_labels }
; return $ AConLike . PatSynCon $ patsyn }}}
where
mk_doc n = text "Pattern synonym" <+> ppr n
tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
; return (id, b) }
tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyConBinders_AT
(map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
bindIfaceIds cv_bndrs $ \ cvs -> do
{ tc_lhs <- tcIfaceTcArgs lhs
; tc_rhs <- tcIfaceType rhs
; let br = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = binderVars tvs
, cab_cvs = cvs
, cab_lhs = tc_lhs
, cab_roles = roles
, cab_rhs = tc_rhs
, cab_incomps = map (prev_branches `getNth`) incomps }
; return (prev_branches ++ [br]) }
tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
= case if_cons of
IfAbstractTyCon -> return AbstractTyCon
IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
where
univ_tvs :: [TyVar]
univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
tag_map :: NameEnv ConTag
tag_map = mkTyConTagMap tycon
tc_con_decl (IfCon { ifConInfix = is_infix,
ifConExTvs = ex_bndrs,
ifConUserTvBinders = user_bndrs,
ifConName = dc_name,
ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = lbl_names,
ifConStricts = if_stricts,
ifConSrcStricts = if_src_stricts})
=
bindIfaceTyVars ex_bndrs $ \ ex_tvs -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
; user_tv_bndrs <- mapM (\(TvBndr (name, _) vis) ->
TvBndr <$> tcIfaceTyVar name <*> pure vis)
user_bndrs
; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
do { eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt
; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
$ mapM tcIfaceType args
; stricts <- mapM tc_strict if_stricts
; return (eq_spec, theta, arg_tys, stricts) }
; let orig_res_ty = mkFamilyTyConApp tycon
(substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
(binderVars tc_tybinders))
; prom_rep_name <- newTyConRepName dc_name
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
dc_name is_infix prom_rep_name
(map src_strict if_src_stricts)
(Just stricts)
lbl_names
univ_tvs ex_tvs user_tv_bndrs
eq_spec theta
arg_tys orig_res_ty tycon tag_map
; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
; return con }
mk_doc con_name = text "Constructor" <+> ppr con_name
tc_strict :: IfaceBang -> IfL HsImplBang
tc_strict IfNoBang = return (HsLazy)
tc_strict IfStrict = return (HsStrict)
tc_strict IfUnpack = return (HsUnpack Nothing)
tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
; return (HsUnpack (Just co)) }
src_strict :: IfaceSrcBang -> HsSrcBang
src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
tcIfaceEqSpec spec
= mapM do_item spec
where
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
; ty <- tcIfaceType if_ty
; return (mkEqSpec tv ty) }
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
, ifInstCls = cls, ifInstTys = mb_tcs
, ifInstOrph = orph })
= do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
fmap tyThingId (tcIfaceImplicit dfun_name)
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
, ifFamInstAxiom = axiom_name } )
= do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
tcIfaceCoAxiom axiom_name
; let axiom'' = toUnbranchedAxiom axiom'
mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedFamInst fam mb_tcs' axiom'') }
tcIfaceRules :: Bool
-> [IfaceRule]
-> IfL [CoreRule]
tcIfaceRules ignore_prags if_rules
| ignore_prags = return []
| otherwise = mapM tcIfaceRule if_rules
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleAuto = auto, ifRuleOrph = orph })
= do { ~(bndrs', args', rhs') <-
forkM (text "Rule" <+> pprRuleName name) $
bindIfaceBndrs bndrs $ \ bndrs' ->
do { args' <- mapM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
; return (bndrs', args', rhs') }
; let mb_tcs = map ifTopFreeName args
; this_mod <- getIfModule
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
ru_origin = this_mod,
ru_orphan = orph,
ru_auto = auto,
ru_local = False }) }
where
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceAnnotations = mapM tcIfaceAnnotation
tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
tcIfaceAnnotation (IfaceAnnotation target serialized) = do
target' <- tcIfaceAnnTarget target
return $ Annotation {
ann_target = target',
ann_value = serialized
}
tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget (NamedTarget occ) = do
name <- lookupIfaceTop occ
return $ NamedTarget name
tcIfaceAnnTarget (ModuleTarget mod) = do
return $ ModuleTarget mod
tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType = go
where
go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2
go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
go (IfaceTyConApp tc tks)
= do { tc' <- tcIfaceTyCon tc
; tks' <- mapM go (tcArgsIfaceTypes tks)
; return (mkTyConApp tc' tks') }
go (IfaceForAllTy bndr t)
= bindIfaceForAllBndr bndr $ \ tv' vis ->
ForAllTy (TvBndr tv' vis) <$> go t
go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type
tcIfaceTupleTy sort is_promoted args
= do { args' <- tcIfaceTcArgs args
; let arity = length args'
; base_tc <- tcTupleTyCon True sort arity
; case is_promoted of
IsNotPromoted
-> return (mkTyConApp base_tc args')
IsPromoted
-> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
kind_args = map typeKind args'
; return (mkTyConApp tc (kind_args ++ args')) } }
tcTupleTyCon :: Bool
-> TupleSort
-> Arity
-> IfL TyCon
tcTupleTyCon in_type sort arity
= case sort of
ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
; return (tyThingTyCon thing) }
BoxedTuple -> return (tupleTyCon Boxed arity)
UnboxedTuple -> return (tupleTyCon Unboxed arity')
where arity' | in_type = arity `div` 2
| otherwise = arity
tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt sts = mapM tcIfaceType sts
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo = go
where
go (IfaceReflCo r t) = Refl r <$> tcIfaceType t
go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
go (IfaceTyConAppCo r tc cs)
= TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
go (IfaceForAllCo tv k c) = do { k' <- go k
; bindIfaceTyVar tv $ \ tv' ->
ForAllCo tv' k' <$> go c }
go (IfaceCoVarCo n) = CoVarCo <$> go_var n
go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
<*> tcIfaceType t1 <*> tcIfaceType t2
go (IfaceSymCo c) = SymCo <$> go c
go (IfaceTransCo c1 c2) = TransCo <$> go c1
<*> go c2
go (IfaceInstCo c1 t2) = InstCo <$> go c1
<*> go t2
go (IfaceNthCo d c) = do { c' <- go c
; return $ mkNthCo (nthCoRole d c') d c' }
go (IfaceLRCo lr c) = LRCo lr <$> go c
go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
<*> go c2
go (IfaceKindCo c) = KindCo <$> go c
go (IfaceSubCo c) = SubCo <$> go c
go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
<*> mapM go cos
go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
go_var :: FastString -> IfL CoVar
go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
= Type <$> tcIfaceType ty
tcIfaceExpr (IfaceCo co)
= Coercion <$> tcIfaceCo co
tcIfaceExpr (IfaceCast expr co)
= Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
tcIfaceExpr (IfaceLcl name)
= Var <$> tcIfaceLclId name
tcIfaceExpr (IfaceExt gbl)
= Var <$> tcIfaceExtId gbl
tcIfaceExpr (IfaceLit lit)
= do lit' <- tcIfaceLit lit
return (Lit lit')
tcIfaceExpr (IfaceFCall cc ty) = do
ty' <- tcIfaceType ty
u <- newUnique
dflags <- getDynFlags
return (Var (mkFCallId dflags u cc ty'))
tcIfaceExpr (IfaceTuple sort args)
= do { args' <- mapM tcIfaceExpr args
; tc <- tcTupleTyCon False sort arity
; let con_tys = map exprType args'
some_con_args = map Type con_tys ++ args'
con_args = case sort of
UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
_ -> some_con_args
con_id = dataConWorkId (tyConSingleDataCon tc)
; return (mkApps (Var con_id) con_args) }
where
arity = length args
tcIfaceExpr (IfaceLam (bndr, os) body)
= bindIfaceBndr bndr $ \bndr' ->
Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
where
tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
tcIfaceOneShot _ b = b
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
; return (castBottomExpr scrut' ty') }
tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
scrut_ty = exprType scrut'
case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
tc_app = splitTyConApp scrut_ty
extendIfaceIdEnv [case_bndr'] $ do
alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False
NotTopLevel name ty' info
; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
`asJoinId_maybe` tcJoinInfo ji
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
= do { ids <- mapM tc_rec_bndr (map fst pairs)
; extendIfaceIdEnv ids $ do
{ pairs' <- zipWithM tc_pair pairs ids
; body' <- tcIfaceExpr body
; return (Let (Rec pairs') body') } }
where
tc_rec_bndr (IfLetBndr fs ty _ ji)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
tc_pair (IfLetBndr _ _ info _, rhs) id
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False
NotTopLevel (idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
tcIfaceExpr (IfaceTick tickish expr) = do
expr' <- tcIfaceExpr expr
dbgLvl <- fmap debugLevel getDynFlags
case tickish of
IfaceSource{} | dbgLvl > 0
-> return expr'
_otherwise -> do
tickish' <- tcIfaceTickish tickish
return (Tick tickish' expr')
tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
tcIfaceLit :: Literal -> IfL Literal
tcIfaceLit (LitNumber LitNumInteger i _)
= do t <- tcIfaceTyConByName integerTyConName
return (mkLitInteger i (mkTyConTy t))
tcIfaceLit (LitNumber LitNumNatural i _)
= do t <- tcIfaceTyConByName naturalTyConName
return (mkLitNatural i (mkTyConTy t))
tcIfaceLit lit = return lit
tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
-> (IfaceConAlt, [FastString], IfaceExpr)
-> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceAlt _ _ (IfaceDefault, names, rhs)
= ASSERT( null names ) do
rhs' <- tcIfaceExpr rhs
return (DEFAULT, [], rhs')
tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
= ASSERT( null names ) do
lit' <- tcIfaceLit lit
rhs' <- tcIfaceExpr rhs
return (LitAlt lit', [], rhs')
tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
= do { con <- tcIfaceDataCon data_occ
; when (debugIsOn && not (con `elem` tyConDataCons tycon))
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt con inst_tys arg_strs rhs }
tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
-> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs con inst_tys
; rhs' <- extendIfaceEnvs ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
tcIdDetails ty IfDFunId
= return (DFunId (isNewTyCon (classTyCon cls)))
where
(_, _, cls, _) = tcSplitDFunTy ty
tcIdDetails _ (IfRecSelId tc naughty)
= do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
(fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
tc
; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
where
tyThingPatSyn (AConLike (PatSynCon ps)) = ps
tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags toplvl name ty info = do
lcl_env <- getLclEnv
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo
if ignore_prags
then return init_info
else case info of
NoInfo -> return init_info
HasInfo info -> foldlM tcPrag init_info info
where
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
tcPrag info (HsUnfold lb if_unf)
= do { unf <- tcUnfolding toplvl name ty info if_unf
; let info1 | lb = info `setOccInfo` strongLoopBreaker
| otherwise = info
; return (info1 `setUnfoldingInfo` unf) }
tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
tcJoinInfo (IfaceJoinPoint ar) = Just ar
tcJoinInfo IfaceNotJoinPoint = Nothing
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
; mb_expr <- tcPragExpr toplvl name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkUnfolding dflags unf_src
True
(isBottomingSig strict_sig)
expr
}
where
strict_sig = strictnessInfo info
tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
= do { mb_expr <- tcPragExpr toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
where
guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
= bindIfaceBndrs bs $ \ bs' ->
do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
(_, _, cls, _) = tcSplitDFunTy dfun_ty
tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr toplvl name expr
= forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr
when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope
dflags <- getDynFlags
case lintUnfolding dflags noSrcLoc in_scope core_expr' of
Nothing -> return ()
Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure"
(vcat [ text "In interface for" <+> ppr mod
, hang doc 2 fail_msg
, ppr name <+> equals <+> ppr core_expr'
, text "Iface expr =" <+> ppr expr ]) }
return core_expr'
where
doc = text "Unfolding of" <+> ppr name
get_in_scope :: IfL VarSet
get_in_scope
= do { (gbl_env, lcl_env) <- getEnvs
; rec_ids <- case if_rec_types gbl_env of
Nothing -> return []
Just (_, get_env) -> do
{ type_env <- setLclEnv () get_env
; return (typeEnvIds type_env) }
; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
bindingsVars (if_id_env lcl_env) `unionVarSet`
mkVarSet rec_ids) }
bindingsVars :: FastStringEnv Var -> VarSet
bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
= do { ifCheckWiredInThing thing; return thing }
| otherwise
= do { env <- getGblEnv
; case if_rec_types env of {
Just (mod, get_type_env)
| nameIsLocalOrFrom mod name
-> do
{ type_env <- setLclEnv () get_type_env
; case lookupNameEnv type_env name of
Just thing -> return thing
Nothing -> via_external
}
; _ -> via_external }}
where
via_external = do
{ hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of {
Just thing -> return thing ;
Nothing -> do
{ mb_thing <- importDecl name
; case mb_thing of
Failed err -> failIfM err
Succeeded thing -> return thing
}}}
tcIfaceTyConByName :: IfExtName -> IfL TyCon
tcIfaceTyConByName name
= do { thing <- tcIfaceGlobal name
; return (tyThingTyCon thing) }
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
; return $ case ifaceTyConIsPromoted info of
IsNotPromoted -> tyThingTyCon thing
IsPromoted -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
; return (tyThingCoAxiom thing) }
tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
tcIfaceCoAxiomRule n
= case Map.lookup n typeNatCoAxiomRules of
Just ax -> return ax
_ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
AConLike (RealDataCon dc) -> return dc
_ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
AnId id -> return id
_ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
tcIfaceImplicit :: Name -> IfL TyThing
tcIfaceImplicit n = do
lcl_env <- getLclEnv
case if_implicits_env lcl_env of
Nothing -> tcIfaceGlobal n
Just tenv ->
case lookupTypeEnv tenv n of
Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
Just tything -> return tything
bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
bindIfaceId (fs, ty) thing_inside
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; let id = mkLocalIdOrCoVar name ty'
; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
bindIfaceIds [] thing_inside = thing_inside []
bindIfaceIds (b:bs) thing_inside
= bindIfaceId b $ \b' ->
bindIfaceIds bs $ \bs' ->
thing_inside (b':bs')
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr (IfaceIdBndr bndr) thing_inside
= bindIfaceId bndr thing_inside
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
= bindIfaceTyVar bndr thing_inside
bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [] thing_inside = thing_inside []
bindIfaceBndrs (b:bs) thing_inside
= bindIfaceBndr b $ \ b' ->
bindIfaceBndrs bs $ \ bs' ->
thing_inside (b':bs')
bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
bindIfaceForAllBndrs [] thing_inside = thing_inside []
bindIfaceForAllBndrs (bndr:bndrs) thing_inside
= bindIfaceForAllBndr bndr $ \tv vis ->
bindIfaceForAllBndrs bndrs $ \bndrs' ->
thing_inside (mkTyVarBinder vis tv : bndrs')
bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
bindIfaceForAllBndr (TvBndr tv vis) thing_inside
= bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars [] thing_inside = thing_inside []
bindIfaceTyVars (tv:tvs) thing_inside
= bindIfaceTyVar tv $ \tv' ->
bindIfaceTyVars tvs $ \tvs' ->
thing_inside (tv' : tvs')
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOccFS occ)
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
mk_iface_tyvar name ifKind
= do { kind <- tcIfaceType ifKind
; return (Var.mkTyVar name kind) }
bindIfaceTyConBinders :: [IfaceTyConBinder]
-> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders [] thing_inside = thing_inside []
bindIfaceTyConBinders (b:bs) thing_inside
= bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' ->
bindIfaceTyConBinders bs $ \ bs' ->
thing_inside (b':bs')
bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
-> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders_AT [] thing_inside
= thing_inside []
bindIfaceTyConBinders_AT (b : bs) thing_inside
= bindIfaceTyConBinderX bind_tv b $ \b' ->
bindIfaceTyConBinders_AT bs $ \bs' ->
thing_inside (b':bs')
where
bind_tv tv thing
= do { mb_tv <- lookupIfaceTyVar tv
; case mb_tv of
Just b' -> thing b'
Nothing -> bindIfaceTyVar tv thing }
bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
-> IfaceTyConBinder
-> (TyConBinder -> IfL a) -> IfL a
bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
= bind_tv tv $ \tv' ->
thing_inside (TvBndr tv' vis)