+tcInterfaceSigs :: GlobalValueEnv -- Envt to use when checking unfoldings
+ -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
+ -> TcM s [Id]
+
+
+tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
+ = tcAddSrcLoc src_loc (
+ tcAddErrCtxt (ifaceSigCtxt name) (
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info ->
+ returnTc (mkImportedId name sigma_ty id_info)
+ )) `thenTc` \ sig_id ->
+ tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
+ returnTc (sig_id : sig_ids)
+
+tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
+
+tcInterfaceSigs unf_env [] = returnTc []
+\end{code}
+
+\begin{code}
+tcIdInfo unf_env name ty info info_ins
+ = foldlTc tcPrag noIdInfo info_ins
+ where
+ tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
+ tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
+ tcPrag info (HsNoCafRefs) = returnTc (NoCafRefs `setCafInfo` info)
+
+ tcPrag info (HsUnfold inline_prag maybe_expr)
+ = (case maybe_expr of
+ Just expr -> tcPragExpr unf_env name expr
+ Nothing -> returnNF_Tc Nothing
+ ) `thenNF_Tc` \ maybe_expr' ->
+ let
+ -- maybe_expr doesn't get looked at if the unfolding
+ -- is never inspected; so the typecheck doesn't even happen
+ unfold_info = case maybe_expr' of
+ Nothing -> NoUnfolding
+ Just expr' -> mkUnfolding expr'
+ info1 = unfold_info `setUnfoldingInfo` info
+
+ info2 = inline_prag `setInlinePragInfo` info1
+ in
+ returnTc info2
+
+ tcPrag info (HsStrictness strict)
+ = tcStrictness unf_env ty info strict
+
+ tcPrag info (HsSpecialise tyvars tys rhs)
+ = tcTyVarScope tyvars $ \ tyvars' ->
+ mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (kinds, tys') ->
+ -- Assume that the kinds match the kinds of the
+ -- type variables of the function; this is, after all, an
+ -- interface file generated by the compiler!
+
+ tcPragExpr unf_env name rhs `thenNF_Tc` \ maybe_rhs' ->
+ let
+ -- If spec_env isn't looked at, none of this
+ -- actually takes place
+ spec_env = specInfo info
+ spec_env' = case maybe_rhs' of
+ Nothing -> spec_env
+ Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of
+ Succeeded spec_env' -> spec_env'
+ Failed err -> pprTrace "tcIdInfo: bad specialisation"
+ (ppr name <+> ppr err) $
+ spec_env
+ in
+ returnTc (spec_env' `setSpecInfo` info)
+\end{code}
+
+\begin{code}
+tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
+ = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
+ uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
+ let
+ -- Watch out! We can't pull on maybe_worker_id too eagerly!
+ info' = case maybe_worker_id of
+ Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
+ setInlinePragInfo IWantToBeINLINEd info
+
+ Nothing -> info
+
+ has_worker = maybeToBool maybe_worker_id
+ in
+ returnTc (StrictnessInfo demands has_worker `setStrictnessInfo` info')
+
+-- Boring to write these out, but the result type differs from the arg type...
+tcStrictness unf_env ty info HsBottom
+ = returnTc (BottomGuaranteed `setStrictnessInfo` info)
+\end{code}
+
+\begin{code}
+tcWorker unf_env Nothing = returnNF_Tc Nothing
+
+tcWorker unf_env (Just (worker_name,_))
+ = returnNF_Tc (trace_maybe maybe_worker_id)
+ where
+ maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
+
+ -- The trace is so we can see what's getting dropped
+ trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
+ trace_maybe (Just x) = Just x
+\end{code}
+
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+
+\begin{code}
+tcPragExpr :: GlobalValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
+tcPragExpr unf_env name core_expr
+ = forkNF_Tc (
+ recoverNF_Tc no_unfolding (
+ tcSetGlobalValEnv unf_env $
+ tcCoreExpr core_expr `thenTc` \ core_expr' ->
+ returnTc (Just core_expr')
+ ))
+ where
+ -- The trace tells what wasn't available, for the benefit of
+ -- compiler hackers who want to improve it!
+ no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
+ returnNF_Tc (pprTrace "tcUnfolding failed with:"
+ (hang (ppr name) 4 (pprBagOfErrors errs))
+ Nothing)
+\end{code}
+
+
+Variables in unfoldings
+~~~~~~~~~~~~~~~~~~~~~~~
+****** Inside here we use only the Global environment, even for locally bound variables.
+****** Why? Because we know all the types and want to bind them to real Ids.
+
+\begin{code}
+tcVar :: Name -> TcM s Id
+tcVar name
+ = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id ->
+ case maybe_id of {
+ Just id -> returnTc id;
+ Nothing -> failWithTc (noDecl name)
+ }
+
+noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
+\end{code}
+
+UfCore expressions.
+
+\begin{code}
+tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+
+tcCoreExpr (UfType ty)
+ = tcHsTypeKind ty `thenTc` \ (_, ty') ->
+ -- It might not be of kind type
+ returnTc (Type ty')
+
+tcCoreExpr (UfVar name)
+ = tcVar name `thenTc` \ id ->
+ returnTc (Var id)
+
+tcCoreExpr (UfCon con args)
+ = tcUfCon con `thenTc` \ con' ->
+ mapTc tcCoreExpr args `thenTc` \ args' ->
+ returnTc (Con con' args')
+
+tcCoreExpr (UfTuple name args)
+ = tcUfDataCon name `thenTc` \ con ->
+ mapTc tcCoreExpr args `thenTc` \ args' ->
+ let
+ -- Put the missing type arguments back in
+ con_args = map (Type . coreExprType) args' ++ args'
+ in
+ returnTc (Con con con_args)