- go info_so_far [] = returnTc info_so_far
- go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
- go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
- go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
- go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
-
- go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
- go (info `addUnfoldInfo` unfold_info) rest
-
- go info (HsStrictness strict : rest) = tcStrictness unf_env ty info strict `thenTc` \ info' ->
- go info' rest
+ tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
+ tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
+ tcPrag info (HsFBType fb) = returnTc (fb `setFBTypeInfo` info)
+ tcPrag info (HsArgUsage au) = returnTc (au `setArgUsageInfo` info)
+
+ tcPrag info (HsUnfold inline expr)
+ = tcPragExpr unf_env name expr `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 = IWantToBeINLINEd `setInlinePragInfo` info1
+ | otherwise = 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)