diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index adfd6b80d..f3938f900 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -143,16 +143,16 @@ say ""; for $statements -> $statement { say "$statement" } -say "type 'a monad = 'a Simple_utils.Trace.result"; -say "let (>>?) v f = Simple_utils.Trace.bind f v"; -say "let return v = Simple_utils.Trace.ok v"; -say "open $moduleName"; -say "module Adt_info = Adt_generator.Generic.Adt_info"; +say "type 'a monad = 'a Simple_utils.Trace.result;;"; +say "let (>>?) v f = Simple_utils.Trace.bind f v;;"; +say "let return v = Simple_utils.Trace.ok v;;"; +say "open $moduleName;;"; +say "module Adt_info = Adt_generator.Generic.Adt_info;;"; say ""; say "(* must be provided by one of the open or include statements: *)"; for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly -{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a) Simple_utils.Trace.result) -> state -> a $poly -> (state * new_a $poly) Simple_utils.Trace.result = fold_map__$poly"; } +{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a) Simple_utils.Trace.result) -> state -> a $poly -> (state * new_a $poly) Simple_utils.Trace.result = fold_map__$poly;;"; } say ""; for $adts.kv -> $index, $t { @@ -165,6 +165,7 @@ for $adts.kv -> $index, $t { default { say " | $c of $c" } } } + say ""; } elsif ($t eq $record) { say ' {'; for $t.list -> $f @@ -178,6 +179,7 @@ for $adts.kv -> $index, $t { say ""; } } +say ";;"; say ""; for $adts.list -> $t { @@ -185,14 +187,14 @@ for $adts.list -> $t { say " node__$t : 'state -> $t -> ('state * $t) monad ;"; for $t.list -> $c { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'}) monad ;" } - say ' }'; + say ' };;'; } say "type 'state continue_fold_map = \{"; for $adts.list -> $t { say " $t : 'state continue_fold_map__$t ;"; } -say ' }'; +say ' };;'; say ""; for $adts.list -> $t @@ -203,24 +205,24 @@ for $adts.list -> $t for $t.list -> $c { say " $t__$c : 'state -> {$c || 'unit'} -> 'state continue_fold_map -> ('state * {$c || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*) } - say '}' } + say '};;' } say "type 'state fold_map_config ="; say ' {'; for $adts.list -> $t { say " $t : 'state fold_map_config__$t;" } -say ' }'; +say ' };;'; say ""; -say "module StringMap = Map.Make(String)"; +say "module StringMap = Map.Make(String);;"; say "(* generic folds for nodes *)"; say "type 'state generic_continue_fold_node = \{"; say " continue : 'state -> 'state ;"; say " (* generic folds for each field *)"; say " continue_ctors_or_fields : ('state -> 'state) StringMap.t ;"; -say '}'; +say '};;'; say "(* map from node names to their generic folds *)"; -say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t"; +say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;"; say ""; say "type 'state fold_config ="; say ' {'; @@ -231,7 +233,7 @@ for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''} # look for built-in polymorphic types for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly { say " $poly : 'a . 'state fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } -say ' }'; +say ' };;'; say ""; say 'type blahblah = {'; @@ -239,7 +241,7 @@ for $adts.list -> $t { say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;"; for $t.list -> $c { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } -say '}'; +say '};;'; # generic programming info about the nodes and fields say ""; @@ -255,7 +257,7 @@ for $adts.list -> $t say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; say " cf = info__$t__$c;"; say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor state x;"; - say '}'; + say '};;'; say ""; } say "(* info for node $t *)"; say "let info__$t : Adt_info.node = \{"; @@ -269,7 +271,7 @@ for $adts.list -> $t print " ctors_or_fields = [ "; for $t.list -> $c { print "info__$t__$c ; "; } say "];"; - say '}'; + say '};;'; say ""; # TODO: factor out some of the common bits here. say "let continue_info__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate Adt_info.instance = fun blahblah visitor x ->"; @@ -309,7 +311,7 @@ for $adts.list -> $t say '};'; } }; - say '}'; + say '};;'; say ""; } say ""; @@ -317,7 +319,7 @@ say "(* info for adt $moduleName *)"; print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; for $adts.list -> $t { print "info__$t ; "; } -say "]"; +say "];;"; # fold functions say ""; @@ -329,18 +331,18 @@ for $adts.list -> $t say " node_instance = continue_info__$t blahblah visitor x"; say ' } in'; # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; - say " visitor.generic state node_instance_info"; + say " visitor.generic state node_instance_info;;"; say ""; for $t.list -> $c { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun blahblah { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->"; # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; if ($c eq '') { # nothing to do, this constructor has no arguments. - say " ignore blahblah; state"; + say " ignore blahblah; state;;"; } elsif ($c) { - say " ignore blahblah; visitor.$c visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + say " ignore blahblah; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } else { - say " blahblah.fold__$c blahblah visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + say " blahblah.fold__$c blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } @@ -352,20 +354,20 @@ for $adts.list -> $t { say " fold__$t;"; for $t.list -> $c { say " fold__$t__$c;" } } -say '}'; +say '};;'; # Tying the knot say ""; for $adts.list -> $t -{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x"; +{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x;;"; for $t.list -> $c - { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x" } } + { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x;;" } } say ""; say "type 'state mk_continue_fold_map = \{"; say " fn : 'state mk_continue_fold_map -> 'state fold_map_config -> 'state continue_fold_map"; -say '}'; +say '};;'; # fold_map functions @@ -376,12 +378,12 @@ for $adts.list -> $t say " visitor.$t.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " return (state, new_x)"; + say " return (state, new_x);;"; say ""; for $t.list -> $c { say "let _fold_map__$t__$c : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }) monad = fun mk_continue_fold_map visitor state x ->"; say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; - say " visitor.$t.$t__$c state x continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + say " visitor.$t.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) say ""; } } # make the "continue" object @@ -396,17 +398,17 @@ for $adts.list -> $t { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } say ' };' } say ' }'; -say '}'; +say '};;'; say ""; # fold_map functions : tying the knot say ""; for $adts.list -> $t { say "let fold_map__$t : type qstate . qstate fold_map_config -> qstate -> $t -> (qstate * $t) monad ="; - say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x"; + say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;"; for $t.list -> $c { say "let fold_map__$t__$c : type qstate . qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }) monad ="; - say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x"; } } + say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } } for $adts.list -> $t @@ -433,7 +435,7 @@ for $adts.list -> $t } else { print " v -> fold_map__$t ( "; print ( "continue.$t.$t__$_" for $t.list ).join(", "); - say " ) state v"; + say " ) state v;;"; } } @@ -455,4 +457,12 @@ for $adts.list -> $t say "let no_op : type state . state fold_map_config = \{"; for $adts.list -> $t { say " $t = no_op__$t;" } -say '}'; +say '};;'; + +say ""; +for $adts.list -> $t +{ say "let with__$t : _ = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; + say "let with__$t__pre_state : _ = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; + say "let with__$t__post_state : _ = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; + for $t.list -> $c + { say "let with__$t__$c : _ = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 617c5914c..f49e42c7d 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -2,6 +2,8 @@ open Amodule open Fold open Simple_utils.Trace +let (|>) v f = f v + module Errors = struct let test_fail msg = let title () = "test failed" in @@ -17,14 +19,13 @@ let test (x : unit result) : unit = match x with let () = test @@ let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in - let op = { - no_op with - a = { no_op.a with - node__a = fun state the_a (*_info*) continue_fold -> - let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in - let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in - ok (state + 1, { a1__' ; a2__' }) } - } in + let op = + no_op |> + with__a (fun state the_a (*_info*) continue_fold -> + let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in + let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in + ok (state + 1, { a1__' ; a2__' })) + in let state = 0 in let%bind (state , _) = fold_map__root op state some_root in if state != 2 then @@ -35,7 +36,8 @@ let () = let () = test @@ let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in - let op = { no_op with a = { no_op.a with node__a__pre_state = fun state _the_a (*_info*) -> ok @@ state + 1 } } in + let op = no_op |> + with__a__pre_state (fun state _the_a (*_info*) -> ok @@ state + 1) in let state = 0 in let%bind (state , _) = fold_map__root op state some_root in if state != 2 then @@ -46,7 +48,7 @@ let () = let () = test @@ let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in - let op = { no_op with a = { no_op.a with node__a__post_state = fun state _the_a _new_a (*_info*) -> ok @@ state + 1 } } in + let op = no_op |> with__a__post_state (fun state _the_a _new_a (*_info*) -> ok @@ state + 1) in let state = 0 in let%bind (state , _) = fold_map__root op state some_root in if state != 2 then @@ -75,7 +77,7 @@ let () = | false, arg -> true, name ^ " " ^ arg) | PolyInstance { poly=_; arguments=_; poly_continue } -> (poly_continue nostate) - ); + ) ; string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ; unit = (fun _visitor state () -> assert_nostate state; false , "()") ; int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;