Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 204 lines (163 sloc) 9.446 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (**
19 Generic Ast Rewriter API.
20
21 This module provides all usual traverse functions and some higher-level ones
22 on any tree structure as long as we consider only one type of nodes
23
24 @author Louis Gesbert
25 @author Valentin Gatien-Baron
26 @author Mathieu Barbin
27 *)
28
29 open TraverseInterface
30
31 (* module type TRAVERSE_LIFT = *)
32 (* sig *)
33 (* val foldmap : ('acc -> 'expr -> 'acc * 'expr) -> 'acc -> 'code_elt -> 'acc * 'code_elt *)
34 (* end *)
35
36
37 (** Some Extensions *)
38 module Utils : sig
39
40 (** A generalisation of the type needed in S
41 ('a, 'at, 'bt ,'b) sub
42 'a may be expressions where identifiers are strings
43 'b an expressions where identfiers are uniq
44 In that case, ('a,'a,'b,'b) represents a function that deconstruct a string expression
45 into a - list of string expression
46 - a function that expects an ident expression list and build you the the 'original' ident expression
47
48 DON'T LOOK at the types, it's too scary
49 Instead take a look at the following example, where you build the subs_cons function for the expressions
50 of some ast:
51 let subs_cons e =
52 match e with
53 | Apply (e1,e2) ->
54 (* (e1,e2) is a pair of expression and you are currently treating
55 * expressions, you write exactly that: *)
56 wrap (fun x -> Apply x) ((sub_2 sub_current sub_current) (e1,e2))
57 | Match pel ->
58 (* pel is a list of pattern * expr
59 * we just ignore the pattern since there is no expression inside them
60 * we stop the deconstruction on the expression, since it is was we are currently deconstructing *)
61 wrap (fun x -> Match x) (sub_list (sub_2 sub_ignore sub_current) pel)
62 | _ -> ...
63
64 *)
65
66 type ('a, 'at, 'bt, 'b) sub = 'a -> ('bt list -> 'b) * 'at list
67
68 val sub_2 : ('a1, 'at, 'bt, 'b1) sub -> ('a2, 'at, 'bt, 'b2) sub -> ('a1 * 'a2, 'at, 'bt, 'b1 * 'b2) sub
69 val sub_3 : ('a1, 'at, 'bt, 'b1) sub -> ('a2, 'at, 'bt, 'b2) sub -> ('a3, 'at, 'bt, 'b3) sub -> ('a1 * 'a2 * 'a3, 'at, 'bt, 'b1 * 'b2 * 'b3) sub
70 val sub_4 : ('a1, 'at, 'bt, 'b1) sub -> ('a2, 'at, 'bt, 'b2) sub -> ('a3, 'at, 'bt, 'b3) sub -> ('a4, 'at, 'bt, 'b4) sub -> ('a1 * 'a2 * 'a3 * 'a4, 'at, 'bt, 'b1 * 'b2 * 'b3 * 'b4) sub
71 val sub_list : ('a, 'at, 'bt, 'b) sub -> ('a list, 'at, 'bt, 'b list) sub
72 val sub_current : ('a, 'a, 'b, 'b) sub
73 val sub_ignore : ('a, _, _, 'a) sub
74
75 val wrap : ('a -> 'b) -> ('at list -> 'a) * 't list -> ('at list -> 'b) * 't list
76 end
77
78 (* HACK: tmp until we merge it into TRAVERSE_CORE for TraverseInterface,
79 and rename it into TRAVERSE *)
80 module type OLD_TRAVERSE =
81 sig
82
83 type 'p t constraint 'p = _ * _ * _
84 val traverse_iter : (('p t -> unit) -> 'p t -> unit) -> 'p t -> unit
85 val traverse_map : (('p t -> 'p t) -> 'p t -> 'p t) -> 'p t -> 'p t
86 val traverse_fold : (('a -> 'p t -> 'a) -> 'a -> 'p t -> 'a) -> 'a -> 'p t -> 'a
87 val traverse_foldmap : (('a -> 'p t -> 'a * 'p t) -> 'a -> 'p t -> 'a * 'p t) -> 'a -> 'p t -> 'a * 'p t
88 val traverse_exists : (('p t -> bool) -> 'p t -> bool) -> 'p t -> bool
89 val traverse_forall : (('p t -> bool) -> 'p t -> bool) -> 'p t -> bool
90 val traverse_fold_context_down : (('env -> 'a -> 'p t -> 'a) -> 'env -> 'a -> 'p t -> 'a) -> 'env -> 'a -> 'p t -> 'a
91 val iter : ('p t -> unit) -> 'p t -> unit
92 val iter_up : ('p t -> unit) -> 'p t -> unit
93 val iter_down : ('p t -> unit) -> 'p t -> unit
94 val map : ('p t -> 'p t) -> 'p t -> 'p t
95 val map_up : ('p t -> 'p t) -> 'p t -> 'p t
96 val map_down : ('p t -> 'p t) -> 'p t -> 'p t
97 val fold : ('a -> 'p t -> 'a) -> 'a -> 'p t -> 'a
98 val fold_up : ('a -> 'p t -> 'a) -> 'a -> 'p t -> 'a
99 val fold_down : ('a -> 'p t -> 'a) -> 'a -> 'p t -> 'a
100 val foldmap : ('a -> 'p t -> 'a * 'p t) -> 'a -> 'p t -> 'a * 'p t
101 val foldmap_up : ('a -> 'p t -> 'a * 'p t) -> 'a -> 'p t -> 'a * 'p t
102 val foldmap_down : ('a -> 'p t -> 'a * 'p t) -> 'a -> 'p t -> 'a * 'p t
103 val exists : ('p t -> bool) -> 'p t -> bool
104 val exists_up : ('p t -> bool) -> 'p t -> bool
105 val exists_down : ('p t -> bool) -> 'p t -> bool
106 val find : ('p t -> bool) -> 'p t -> 'p t option
107 val find_up : ('p t -> bool) -> 'p t -> 'p t option
108 val find_down : ('p t -> bool) -> 'p t -> 'p t option
109 val findmap : ('p t -> 'a option) -> 'p t -> 'a option
110 val findmap_up : ('p t -> 'a option) -> 'p t -> 'a option
111 val findmap_down : ('p t -> 'a option) -> 'p t -> 'a option
112
113
114 (** traverse all the nodes of the tree in an unspecified order *)
115 val traverse_fold_right : (('b t -> 'a -> 'a) -> 'b t -> 'a -> 'a) -> 'b t -> 'a -> 'a
116
117 (** [fold_up_combine ?combine f acc0 t] folds [f] from leaves with [acc0], combining
118 accumulators from sub-trees with [combine] before calling [f].
119 Default value for combine is (fun _ b -> b)
120 <!> Be carefull be using this function without combine, lots of accs are lost *)
121 val fold_up_combine : ?combine:('a -> 'a -> 'a) -> ('a -> 'b t -> 'a) -> 'a -> 'b t -> 'a
122
123 (** Folds all the nodes of the tree in an unspecified order *)
124 val fold_right_down : ('b t -> 'a -> 'a) -> 'b t -> 'a -> 'a
125 val foldmap_up_combine : ?combine:('a -> 'a -> 'a) -> ('a -> 'b t -> 'a * 'b t) -> 'a -> 'b t -> 'a * 'b t
126
127 (** Non-recursive versions, e.g. if you want to handle recursion yourself and have a default case *)
128 val map_nonrec : ('b t -> 'b t) -> 'b t -> 'b t
129 val fold_nonrec : ('a -> 'b t -> 'a) -> 'a -> 'b t -> 'a
130 val foldmap_nonrec : ('a -> 'b t -> 'a * 'b t) -> 'a -> 'b t -> 'a * 'b t
131
132 (** Just because we had fun writing it. Don't use as is, it's probably very slow.
133 Applies the rewriting until fixpoint reached *)
134 val map_down_fix : ('b t -> 'b t) -> 'b t -> 'b t
135
136 (** Additional functions that let you traverse the type 'c t when they are deep into an arbitrary structure 'b
137 as long as you provide the functions to unbuild/rebuild 'b into t lists *)
138 type ('b, 'c) sub = ('b, 'c t, 'c t , 'b) Utils.sub
139
140 val lift_iter_up : ('b,'c) sub -> ('c t -> unit) -> ('b -> unit)
141 val lift_iter_down : ('b,'c) sub -> ('c t -> unit) -> ('b -> unit)
142 val lift_map_up : ('b,'c) sub -> ('c t -> 'c t) -> ('b -> 'b)
143 val lift_map_down : ('b,'c) sub -> ('c t -> 'c t) -> ('b -> 'b)
144 (* like fold_map_up_for_real *)
145 val lift_fold_up_combine : ('b,'c) sub -> ?combine:('a -> 'a -> 'a) -> ('a -> 'c t -> 'a) -> ('a -> 'b -> 'a)
146 val lift_fold : ('b,'c) sub -> ('a -> 'c t -> 'a) -> ('a -> 'b -> 'a)
147 val lift_fold_right_down : ('b,'c) sub -> ('c t -> 'a -> 'a) -> ('b -> 'a -> 'a)
148 val lift_foldmap_up : ('b,'c) sub -> ('a -> 'c t -> 'a * 'c t) -> ('a -> 'b -> 'a * 'b)
149 val lift_foldmap_down : ('b,'c) sub -> ('a -> 'c t -> 'a * 'c t) -> ('a -> 'b -> 'a * 'b)
150 val lift_exists : ('b,'c) sub -> ('c t -> bool) -> ('b -> bool)
151 end
152
153
154 (** {6 First implementation} *)
155
156
157 (** Functor giving you the usual traverse functions *)
158 module Make (X : S) : OLD_TRAVERSE with type 'a t = 'a X.t
159
160 (** Functor for map2, fold2, etc. *)
161 module MakePair (Fst : S) (Snd : S) : OLD_TRAVERSE with type 'a t = 'a Fst.t * 'a Snd.t
162
163 (** {6 Second implementation} *)
164
165 (** For the second version (S2), you may do not want to write the optimised version of fold, map, iter
166 in this case you can use this unoptimzed constructors, to get them from the foldmap_children function *)
167 module Unoptimized :
168 sig
169 (** Simple recursion *)
170 type ('acc, 't, 't2) foldmap = ('acc -> 't -> 'acc * 't) -> 'acc -> 't2 -> 'acc * 't2
171 val iter : (unit, 't, 't2) foldmap -> ('t -> unit) -> 't2 -> unit
172 val map : (unit, 't, 't2) foldmap -> ('t -> 't) -> 't2 -> 't2
173 val fold : ('acc, 't, 't2) foldmap -> ('acc -> 't -> 'acc) -> 'acc -> 't2 -> 'acc
174
175 (** Mutual recursion *)
176 type ('acc, 'tA, 'tB) foldmapAB =
177 ('acc -> 'tA -> 'acc * 'tA) ->
178 ('acc -> 'tB -> 'acc * 'tB) ->
179 'acc -> 'tA -> 'acc * 'tA
180 val iterAB : (unit, 'tA, 'tB) foldmapAB -> ('tA -> unit) -> ('tB -> unit) -> 'tA -> unit
181 val mapAB : (unit, 'tA, 'tB) foldmapAB -> ('tA -> 'tA) -> ('tB -> 'tB) -> 'tA -> 'tA
182 val foldAB : ('acc, 'tA, 'tB) foldmapAB -> ('acc -> 'tA -> 'acc) -> ('acc -> 'tB -> 'acc) -> 'acc -> 'tA -> 'acc
183 end
184
185 open TraverseInterface
186 module Make2 (X : S2) : TRAVERSE with type 'a t = 'a X.t and type 'a container = 'a X.t
187
188 module MakeLift1
189 (Y : LIFT2)
190 (X : TRAVERSE with type 'a container = 'a Y.t and type 'a t = 'a Y.t)
191 : TRAVERSE with type 'a t = 'a X.t and type 'a container = 'a Y.container
192
193 module MakeLift2
194 (Y : LIFT2)
195 (X : TRAVERSE with type 'a container = 'a Y.t)
196 : TRAVERSE with type 'a t = 'a X.t and type 'a container = 'a Y.container
197
198 (* From there, you can build Box of Boxes with MakeBox *)
199 (* for example, for rewriting rules on a tuple of code, etc...*)
200
201 (** {6 Mutual Recursive Trees} *)
202
203 module MakeAB (AB : AB) : TRAVERSE_AB with type 'a tA = 'a AB.tA and type 'a tB = 'a AB.tB
Something went wrong with that request. Please try again.