From e0011547140609a0f7a95b5ddb1d211d01846d71 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= <ligo@suzanne.soy>
Date: Sun, 5 Apr 2020 20:17:55 +0200
Subject: [PATCH] with_xxx shorthands for fold configurations

---
 src/stages/adt_generator/generator.raku | 78 ++++++++++++++-----------
 src/test/adt_generator/use_a_fold.ml    | 24 ++++----
 2 files changed, 57 insertions(+), 45 deletions(-)

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({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).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<newName> of $c<newType>" }
           }
       }
+      say "";
   } elsif ($t<kind> eq $record) {
       say '  {';
       for $t<ctorsOrFields>.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<name> : 'state -> $t<name> -> ('state * $t<newName>) monad ;";
     for $t<ctorsOrFields>.list -> $c
     { say "    $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'}) monad ;" }
-    say '  }';
+    say '  };;';
 }
 
 say "type 'state continue_fold_map = \{";
 for $adts.list -> $t {
     say "    $t<name> : 'state continue_fold_map__$t<name> ;";
 }
-say '  }';
+say '  };;';
 
 say "";
 for $adts.list -> $t
@@ -203,24 +205,24 @@ for $adts.list -> $t
   for $t<ctorsOrFields>.list -> $c
   { say "    $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> 'state continue_fold_map -> ('state * {$c<newType> || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
   }
-  say '}' }
+  say '};;' }
 
 say "type 'state fold_map_config =";
 say '  {';
 for $adts.list -> $t
 { say "    $t<name> : 'state fold_map_config__$t<name>;" }
-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({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}
 # look for built-in polymorphic types
 for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).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<name> : 'state . blahblah -> 'state fold_config -> 'state -> $t<name> -> 'state;";
   for $t<ctorsOrFields>.list -> $c
   { say "  fold__$t<name>__$c<name> : 'state . blahblah -> 'state fold_config -> 'state -> { $c<type> || '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<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
     say "  cf = info__$t<name>__$c<name>;";
     say "  cf_continue = fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x;";
-    say '}';
+    say '};;';
     say ""; }
   say "(* info for node $t<name> *)";
   say "let info__$t<name> : Adt_info.node = \{";
@@ -269,7 +271,7 @@ for $adts.list -> $t
   print "  ctors_or_fields = [ ";
   for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
   say "];";
-  say '}';
+  say '};;';
   say "";
   # TODO: factor out some of the common bits here.
   say "let continue_info__$t<name> : type qstate . blahblah -> qstate fold_config -> $t<name> -> 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<name> ; "; }
-say "]";
+say "];;";
 
 # fold functions
 say "";
@@ -329,18 +331,18 @@ for $adts.list -> $t
   say "    node_instance = continue_info__$t<name> blahblah visitor x";
   say '  } in';
   # say "  let (state, new_x) = visitor.$t<name>.node__$t<name> x (fun () -> whole_adt_info, info__$t<name>) state continue_fold in";
-  say "  visitor.generic state node_instance_info";
+  say "  visitor.generic state node_instance_info;;";
   say "";
   for $t<ctorsOrFields>.list -> $c
   { say "let fold__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun blahblah { $c<type> ?? 'visitor' !! '_visitor' } state { $c<type> ?? 'x' !! '()' } ->";
     # say "  let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
     if ($c<type> eq '') {
         # nothing to do, this constructor has no arguments.
-        say "  ignore blahblah; state";
+        say "  ignore blahblah; state;;";
     } elsif ($c<isBuiltin>) {
-        say "  ignore blahblah; visitor.$c<type> visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) 
+        say "  ignore blahblah; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) 
     } else {
-        say "  blahblah.fold__$c<type> blahblah visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
+        say "  blahblah.fold__$c<type> blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
     }
     # say "  visitor.$t<name>.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
     say ""; }
@@ -352,20 +354,20 @@ for $adts.list -> $t
 { say "  fold__$t<name>;";
   for $t<ctorsOrFields>.list -> $c
   { say "  fold__$t<name>__$c<name>;" } }
-say '}';
+say '};;';
 
 # Tying the knot
 say "";
 for $adts.list -> $t
-{ say "let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> blahblah visitor state x";
+{ say "let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> blahblah visitor state x;;";
   for $t<ctorsOrFields>.list -> $c
-  { say "let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> blahblah visitor state x" } }
+  { say "let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> 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<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
   say "  visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
   say "  visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
-  say "  return (state, new_x)";
+  say "  return (state, new_x);;";
   say "";
   for $t<ctorsOrFields>.list -> $c
   { say "let _fold_map__$t<name>__$c<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || '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<name>.$t<name>__$c<name> state x continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
+    say "  visitor.$t<name>.$t<name>__$c<name> state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
     say ""; } }
 
 # make the "continue" object
@@ -396,17 +398,17 @@ for $adts.list -> $t
   { say "        $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> 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<name> : type qstate . qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad =";
-  say "  fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x";
+  say "  fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x;;";
   for $t<ctorsOrFields>.list -> $c
   { say "let fold_map__$t<name>__$c<name> : type qstate . qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad =";
-    say "  fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x"; } }
+    say "  fun visitor state x -> _fold_map__$t<name>__$c<name> 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<kind> ( ";
     print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.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<name> = no_op__$t<name>;" }
-say '}';
+say '};;';
+
+say "";
+for $adts.list -> $t
+{ say "let with__$t<name> : _ = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
+  say "let with__$t<name>__pre_state : _ = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
+  say "let with__$t<name>__post_state : _ = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
+  for $t<ctorsOrFields>.list -> $c
+  { say "let with__$t<name>__$c<name> : _ = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }
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) ;