fold_config hook to update the state after a node has been transformed, without transforming it.
This commit is contained in:
parent
8b98898dbf
commit
fe5f8d9f64
@ -36,16 +36,20 @@ type 'state continue_fold =
|
|||||||
type 'state fold_config =
|
type 'state fold_config =
|
||||||
{
|
{
|
||||||
root : root -> 'state -> ('state continue_fold) -> (root' * 'state) ;
|
root : root -> 'state -> ('state continue_fold) -> (root' * 'state) ;
|
||||||
|
root_post_state : root -> root' -> 'state -> 'state ;
|
||||||
root_A : a -> 'state -> ('state continue_fold) -> (a' * 'state) ;
|
root_A : a -> 'state -> ('state continue_fold) -> (a' * 'state) ;
|
||||||
root_B : int -> 'state -> ('state continue_fold) -> (int * 'state) ;
|
root_B : int -> 'state -> ('state continue_fold) -> (int * 'state) ;
|
||||||
root_C : string -> 'state -> ('state continue_fold) -> (string * 'state) ;
|
root_C : string -> 'state -> ('state continue_fold) -> (string * 'state) ;
|
||||||
a : a -> 'state -> ('state continue_fold) -> (a' * 'state) ;
|
a : a -> 'state -> ('state continue_fold) -> (a' * 'state) ;
|
||||||
|
a_post_state : a -> a' -> 'state -> 'state ;
|
||||||
a_a1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ;
|
a_a1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ;
|
||||||
a_a2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
a_a2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||||
ta1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ;
|
ta1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ;
|
||||||
|
ta1_post_state : ta1 -> ta1' -> 'state -> 'state ;
|
||||||
ta1_X : root -> 'state -> ('state continue_fold) -> (root' * 'state) ;
|
ta1_X : root -> 'state -> ('state continue_fold) -> (root' * 'state) ;
|
||||||
ta1_Y : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
ta1_Y : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||||
ta2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
ta2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||||
|
ta2_post_state : ta2 -> ta2' -> 'state -> 'state ;
|
||||||
ta2_Z : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
ta2_Z : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||||
ta2_W : unit -> 'state -> ('state continue_fold) -> (unit * 'state) ;
|
ta2_W : unit -> 'state -> ('state continue_fold) -> (unit * 'state) ;
|
||||||
}
|
}
|
||||||
@ -70,7 +74,9 @@ let rec mk_continue_fold : type state . state fold_config -> state continue_fold
|
|||||||
|
|
||||||
and fold_root : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state ->
|
and fold_root : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
visitor.root x state continue_fold
|
let (new_x, state) = visitor.root x state continue_fold in
|
||||||
|
let state = visitor.root_post_state x new_x state in
|
||||||
|
(new_x, state)
|
||||||
|
|
||||||
and fold_root_A : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state ->
|
and fold_root_A : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
@ -86,7 +92,9 @@ and fold_root_C : type state . state fold_config -> string -> state -> (string *
|
|||||||
|
|
||||||
and fold_a : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state ->
|
and fold_a : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
visitor.a x state continue_fold
|
let (new_x, state) = visitor.a x state continue_fold in
|
||||||
|
let state = visitor.a_post_state x new_x state in
|
||||||
|
(new_x, state)
|
||||||
|
|
||||||
and fold_a_a1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state ->
|
and fold_a_a1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
@ -98,7 +106,9 @@ and fold_a_a2 : type state . state fold_config -> ta2 -> state -> (ta2' * state)
|
|||||||
|
|
||||||
and fold_ta1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state ->
|
and fold_ta1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
visitor.ta1 x state continue_fold
|
let (new_x, state) = visitor.ta1 x state continue_fold in
|
||||||
|
let state = visitor.ta1_post_state x new_x state in
|
||||||
|
(new_x, state)
|
||||||
|
|
||||||
and fold_ta1_X : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state ->
|
and fold_ta1_X : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
@ -110,7 +120,9 @@ and fold_ta1_Y : type state . state fold_config -> ta2 -> state -> (ta2' * state
|
|||||||
|
|
||||||
and fold_ta2 : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
and fold_ta2 : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
visitor.ta2 x state continue_fold
|
let (new_x, state) = visitor.ta2 x state continue_fold in
|
||||||
|
let state = visitor.ta2_post_state x new_x state in
|
||||||
|
(new_x, state)
|
||||||
|
|
||||||
and fold_ta2_Z : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
and fold_ta2_Z : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
||||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||||
@ -127,6 +139,7 @@ let no_op : 'a fold_config = {
|
|||||||
| B v -> let (v, state) = continue.root_B v state in (B' v, state)
|
| B v -> let (v, state) = continue.root_B v state in (B' v, state)
|
||||||
| C v -> let (v, state) = continue.root_C v state in (C' v, state)
|
| C v -> let (v, state) = continue.root_C v state in (C' v, state)
|
||||||
);
|
);
|
||||||
|
root_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||||
root_A = (fun v state continue -> continue.a v state ) ;
|
root_A = (fun v state continue -> continue.a v state ) ;
|
||||||
root_B = (fun v state continue -> ignore continue; (v, state) ) ;
|
root_B = (fun v state continue -> ignore continue; (v, state) ) ;
|
||||||
root_C = (fun v state continue -> ignore continue; (v, state) ) ;
|
root_C = (fun v state continue -> ignore continue; (v, state) ) ;
|
||||||
@ -137,6 +150,7 @@ let no_op : 'a fold_config = {
|
|||||||
let (a2', state) = continue.a_a2 a2 state in
|
let (a2', state) = continue.a_a2 a2 state in
|
||||||
({ a1'; a2'; }, state)
|
({ a1'; a2'; }, state)
|
||||||
);
|
);
|
||||||
|
a_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||||
a_a1 = (fun v state continue -> continue.ta1 v state ) ;
|
a_a1 = (fun v state continue -> continue.ta1 v state ) ;
|
||||||
a_a2 = (fun v state continue -> continue.ta2 v state ) ;
|
a_a2 = (fun v state continue -> continue.ta2 v state ) ;
|
||||||
ta1 = (fun v state continue ->
|
ta1 = (fun v state continue ->
|
||||||
@ -144,6 +158,7 @@ let no_op : 'a fold_config = {
|
|||||||
| X v -> let (v, state) = continue.ta1_X v state in (X' v, state)
|
| X v -> let (v, state) = continue.ta1_X v state in (X' v, state)
|
||||||
| Y v -> let (v, state) = continue.ta1_Y v state in (Y' v, state)
|
| Y v -> let (v, state) = continue.ta1_Y v state in (Y' v, state)
|
||||||
);
|
);
|
||||||
|
ta1_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||||
ta1_X = (fun v state continue -> continue.root v state ) ;
|
ta1_X = (fun v state continue -> continue.root v state ) ;
|
||||||
ta1_Y = (fun v state continue -> continue.ta2 v state ) ;
|
ta1_Y = (fun v state continue -> continue.ta2 v state ) ;
|
||||||
ta2 = (fun v state continue ->
|
ta2 = (fun v state continue ->
|
||||||
@ -151,6 +166,7 @@ let no_op : 'a fold_config = {
|
|||||||
| Z v -> let (v, state) = continue.ta2_Z v state in (Z' v, state)
|
| Z v -> let (v, state) = continue.ta2_Z v state in (Z' v, state)
|
||||||
| W v -> let (v, state) = continue.ta2_W v state in (W' v, state)
|
| W v -> let (v, state) = continue.ta2_W v state in (W' v, state)
|
||||||
);
|
);
|
||||||
|
ta2_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||||
ta2_Z = (fun v state continue -> continue.ta2 v state ) ;
|
ta2_Z = (fun v state continue -> continue.ta2 v state ) ;
|
||||||
ta2_W = (fun v state continue -> ignore continue; (v, state) ) ;
|
ta2_W = (fun v state continue -> ignore continue; (v, state) ) ;
|
||||||
}
|
}
|
||||||
|
@ -58,26 +58,24 @@ for (index, t) in enumerate(adts):
|
|||||||
print(f" {f.newName} : {f.newType} ;")
|
print(f" {f.newName} : {f.newType} ;")
|
||||||
print(" }")
|
print(" }")
|
||||||
|
|
||||||
|
print("")
|
||||||
# print("")
|
print(f"type 'state continue_fold =")
|
||||||
# print("type 'state continue_fold =")
|
print(" {")
|
||||||
# print(" {")
|
for t in adts:
|
||||||
# for t in adts:
|
print(f" {t.name} : {t.name} -> 'state -> ({t.newName} * 'state) ;")
|
||||||
# print(f" {t.name} : {t.name} -> 'state -> ({t.newName} * 'state) ;")
|
|
||||||
# print(" }")
|
|
||||||
|
|
||||||
def folder(name, extraArgs):
|
|
||||||
print("")
|
|
||||||
print(f"type 'state {name} =")
|
|
||||||
print(" {")
|
|
||||||
for t in adts:
|
|
||||||
print(f" {t.name} : {t.name} -> 'state{extraArgs} -> ({t.newName} * 'state) ;")
|
|
||||||
for c in t.ctorsOrFields:
|
for c in t.ctorsOrFields:
|
||||||
print(f" {t.name}_{c.name} : {c.type_} -> 'state{extraArgs} -> ({c.newType} * 'state) ;")
|
print(f" {t.name}_{c.name} : {c.type_} -> 'state -> ({c.newType} * 'state) ;")
|
||||||
print(" }")
|
print(" }")
|
||||||
|
|
||||||
folder("continue_fold", "")
|
print("")
|
||||||
folder("fold_config", " -> ('state continue_fold)")
|
print(f"type 'state fold_config =")
|
||||||
|
print(" {")
|
||||||
|
for t in adts:
|
||||||
|
print(f" {t.name} : {t.name} -> 'state -> ('state continue_fold) -> ({t.newName} * 'state) ;")
|
||||||
|
print(f" {t.name}_post_state : {t.name} -> {t.newName} -> 'state -> 'state ;")
|
||||||
|
for c in t.ctorsOrFields:
|
||||||
|
print(f" {t.name}_{c.name} : {c.type_} -> 'state -> ('state continue_fold) -> ({c.newType} * 'state) ;")
|
||||||
|
print(" }")
|
||||||
|
|
||||||
print("")
|
print("")
|
||||||
print('(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)')
|
print('(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)')
|
||||||
@ -93,7 +91,9 @@ print("")
|
|||||||
for t in adts:
|
for t in adts:
|
||||||
print(f"and fold_{t.name} : type state . state fold_config -> {t.name} -> state -> ({t.newName} * state) = fun visitor x state ->")
|
print(f"and fold_{t.name} : type state . state fold_config -> {t.name} -> state -> ({t.newName} * state) = fun visitor x state ->")
|
||||||
print(" let continue_fold : state continue_fold = mk_continue_fold visitor in")
|
print(" let continue_fold : state continue_fold = mk_continue_fold visitor in")
|
||||||
print(f" visitor.{t.name} x state continue_fold")
|
print(f" let (new_x, state) = visitor.{t.name} x state continue_fold in")
|
||||||
|
print(f" let state = visitor.{t.name}_post_state x new_x state in")
|
||||||
|
print(" (new_x, state)")
|
||||||
print("")
|
print("")
|
||||||
for c in t.ctorsOrFields:
|
for c in t.ctorsOrFields:
|
||||||
print(f"and fold_{t.name}_{c.name} : type state . state fold_config -> {c.type_} -> state -> ({c.newType} * state) = fun visitor x state ->")
|
print(f"and fold_{t.name}_{c.name} : type state . state fold_config -> {c.type_} -> state -> ({c.newType} * state) = fun visitor x state ->")
|
||||||
@ -101,35 +101,6 @@ for t in adts:
|
|||||||
print(f" visitor.{t.name}_{c.name} x state continue_fold")
|
print(f" visitor.{t.name}_{c.name} x state continue_fold")
|
||||||
print("")
|
print("")
|
||||||
|
|
||||||
# print(" match x with")
|
|
||||||
# if t.isVariant:
|
|
||||||
# for c in t.ctorsOrFields:
|
|
||||||
# print(f" | {c.name} v ->")
|
|
||||||
# print(f" let (v', state) = visitor.{t.name}_{c.name} v state continue_fold in")
|
|
||||||
# print(f" ({c.newName} v', state)")
|
|
||||||
# else:
|
|
||||||
# print(" | {", end=' ')
|
|
||||||
# for f in t.ctorsOrFields:
|
|
||||||
# print(f"{f.name};", end=' ')
|
|
||||||
# print("} ->")
|
|
||||||
# for f in t.ctorsOrFields:
|
|
||||||
# print(f" let ({f.newName}, state) = visitor.{t.name}_{f.name} {f.name} state continue_fold in")
|
|
||||||
# print(" ({", end=' ')
|
|
||||||
# for f in t.ctorsOrFields:
|
|
||||||
# print(f"{f.newName};", end=' ')
|
|
||||||
# print("}, state)")
|
|
||||||
# print("")
|
|
||||||
# for c in t.ctorsOrFields:
|
|
||||||
# print(f"and fold_{t.name}_{c.name} : type state . state fold_config -> {c.type_} -> state -> ({c.newType} * state) = fun visitor x state ->")
|
|
||||||
# if c.isBuiltin:
|
|
||||||
# print(" ignore visitor; (x, state)")
|
|
||||||
# else:
|
|
||||||
# print(" let continue_fold : state continue_fold = mk_continue_fold visitor in")
|
|
||||||
# print(f" visitor.{c.type_} x state continue_fold")
|
|
||||||
# print("")
|
|
||||||
|
|
||||||
# print """let no_op : ('a -> unit) -> 'a fold_config = fun phantom -> failwith "todo" """
|
|
||||||
|
|
||||||
print("let no_op : 'a fold_config = {")
|
print("let no_op : 'a fold_config = {")
|
||||||
for t in adts:
|
for t in adts:
|
||||||
print(f" {t.name} = (fun v state continue ->")
|
print(f" {t.name} = (fun v state continue ->")
|
||||||
@ -149,6 +120,7 @@ for t in adts:
|
|||||||
print(f"{f.newName};", end=' ')
|
print(f"{f.newName};", end=' ')
|
||||||
print("}, state)")
|
print("}, state)")
|
||||||
print(" );")
|
print(" );")
|
||||||
|
print(f" {t.name}_post_state = (fun v new_v state -> ignore (v, new_v); state) ;")
|
||||||
for c in t.ctorsOrFields:
|
for c in t.ctorsOrFields:
|
||||||
print(f" {t.name}_{c.name} = (fun v state continue ->", end=' ')
|
print(f" {t.name}_{c.name} = (fun v state continue ->", end=' ')
|
||||||
if c.isBuiltin:
|
if c.isBuiltin:
|
||||||
@ -157,28 +129,3 @@ for t in adts:
|
|||||||
print(f"continue.{c.type_} v state", end=' ')
|
print(f"continue.{c.type_} v state", end=' ')
|
||||||
print(") ;")
|
print(") ;")
|
||||||
print("}")
|
print("}")
|
||||||
|
|
||||||
|
|
||||||
# (fun v state continue ->
|
|
||||||
# let (new_v, new_state) = match v with
|
|
||||||
# | A v -> let (v, state) = continue.a v state in (A' v, state)
|
|
||||||
# | B v -> let (v, state) = (fun x s -> (x,s)) v state in (B' v, state)
|
|
||||||
# | C v -> let (v, state) = (fun x s -> (x,s)) v state in (C' v, state)
|
|
||||||
# in
|
|
||||||
# (new_v, new_state)
|
|
||||||
# );
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# if not builtin:
|
|
||||||
# print (" let (v', state) = match v' with None -> visitor.%s v state continue_fold | Some v' -> (v', state) in" % (ct,))
|
|
||||||
# else:
|
|
||||||
# print " let Some v' = v' in"
|
|
||||||
|
|
||||||
# if not builtin:
|
|
||||||
# print (" let (%s, state) = match %s with None -> visitor.%s %s state continue_fold | Some v' -> (v', state) in" % (ff, ff, ft, f))
|
|
||||||
# else:
|
|
||||||
# print " let Some v' = v' in"
|
|
||||||
|
Loading…
Reference in New Issue
Block a user