Replace at given levels, but ignore subexpressions with specified heads

Question

I'm implementing a function tacit1 that constructs a pure function by applying all Symbols to #. E.g.

tacit1[IntegerPartitions[Max, Length/2, Select[Most, # < 10&]]]

(* IntegerPartitions[Max[#], Length[#]/2, Select[Most[#], # < 10&]]& *)

However, I also need the ability to escape symbols, say with a head tacitVerbatim, so that tacit1 does not enter expressions with head tacitVerbatim. (Maybe Compose and other higher-order functions should automatically be excluded too.)

tacit1[SortBy[Most, tacitVerbatim[ Abs @* Sin]]]
(* SortBy[Most[#], Abs @* Sin]& *)

I tried the answer to How to ReplaceAll except within specified heads, but ReplaceAll enters Heads by default, and tries to replace the IntegerPartitions head with IntegerPartitions[#]. I also need to specify levels to keep the outer Function from being replaced.

Replace examines expressions from deepest to shallowest, so the trick that keeps ReplaceAll out of certain expressions doesn't work.

I'm thinking of manually searching the expression tree, but is there a more elegant idea?

Answer 1

I think this might work:

SetAttributes[{tacit1, hide}, HoldAll]
tacit1[e_]:=With[{g = hide[e]},
    Replace[
        g[[1]],
        s_Symbol /; !MemberQ[Attributes[s], Temporary] :> s[#],
        {2, Infinity}
    ] /. g[[2]]
]

hide[e_] := Reap[
    ReplaceAll[
        Function[e],
        tacitVerbatim[t_] :> RuleCondition @ Module[{x}, Sow[x, Unevaluated[t]]]
    ],
    _,
    toRuleDelayed
]

SetAttributes[toRuleDelayed,HoldAll]

toRuleDelayed[x_, {s_}] := s :> x

Your examples:

tacit1[IntegerPartitions[Max, Length/2, Select[Most,#<10&]]]

IntegerPartitions[Max[#1], Length[#1]/2, Select[Most[#1], #1 < 10 &]] &

tacit1[SortBy[Most, tacitVerbatim[ Abs @* Sin]]]

SortBy[Most[#1], Abs@*Sin] &