From 08aefa45805f0867c3c2ebe33360949e5a3d9acc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= <ligo@suzanne.soy>
Date: Fri, 13 Mar 2020 17:16:17 +0100
Subject: [PATCH] Use unique field names in generic.ml and re-enable warning 30
 there

---
 src/stages/adt_generator/generator.raku | 71 ++++++++++++-------------
 src/stages/adt_generator/generic.ml     | 47 ++++++++--------
 src/stages/adt_generator/use_a_fold.ml  | 14 ++---
 3 files changed, 68 insertions(+), 64 deletions(-)

diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku
index 5c7874891..71ab1286e 100644
--- a/src/stages/adt_generator/generator.raku
+++ b/src/stages/adt_generator/generator.raku
@@ -169,11 +169,11 @@ say "";
 say "type 'state fold_map_config =";
 say '  {';
 for $adts.list -> $t
-{ say "    $t<name> : $t<name> -> (*Adt_info.node_info ->*) 'state -> ('state continue_fold_map) -> ($t<newName> * 'state) ;";
-  say "    $t<name>_pre_state : $t<name> -> (*Adt_info.node_info ->*) 'state -> 'state ;";
-  say "    $t<name>_post_state : $t<name> -> $t<newName> -> (*Adt_info.node_info ->*) 'state -> 'state ;";
+{ say "    $t<name> : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t<newName> * 'state) ;";
+  say "    $t<name>_pre_state : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
+  say "    $t<name>_post_state : $t<name> -> $t<newName> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
   for $t<ctorsOrFields>.list -> $c
-  { say "    $t<name>_$c<name> : $c<type> -> (*Adt_info.ctor_or_field_info ->*) 'state -> ('state continue_fold_map) -> ($c<newType> * 'state) ;";
+  { say "    $t<name>_$c<name> : $c<type> -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ($c<newType> * 'state) ;";
   } }
 say '  }';
 
@@ -190,7 +190,7 @@ say "type 'state generic_continue_fold = ('state generic_continue_fold_node) Str
 say "";
 say "type 'state fold_config =";
 say '  {';
-say "    generic : 'state Adt_info.node_info -> 'state -> 'state;";
+say "    generic : 'state Adt_info.node_instance_info -> 'state -> 'state;";
 for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin>}).map({$_<type>}).unique -> $builtin
 { say "    $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; }
 for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $builtin
@@ -209,16 +209,13 @@ for $adts.list -> $t
   { say "(* info for field or ctor $t<name>.$c<name> *)";
     say "and info_$t<name>_$c<name> : Adt_info.ctor_or_field = \{";
     say "  name = \"$c<name>\";";
-    say "  isBuiltin = {$c<isBuiltin> ?? 'true' !! 'false'};";
+    say "  is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
     say "  type_ = \"$c<type>\";";
     say '}';
     say "";
-    # TODO: factor out some of the common bits here.
-    say "and continue_info_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate Adt_info.ctor_or_field_continue = fun visitor x -> \{";
-    say "  name = \"$c<name>\";";
-    say "  isBuiltin = {$c<isBuiltin> ?? 'true' !! 'false'};";
-    say "  type_ = \"$c<type>\";";
-    say "  continue = fun state -> fold_$t<name>_$c<name> visitor x state;";
+    say "and continue_info_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{";
+    say "  cf = info_$t<name>_$c<name>;";
+    say "  cf_continue = fun state -> fold_$t<name>_$c<name> visitor x state;";
     say '}';
     say ""; }
   say "(* info for node $t<name> *)";
@@ -229,7 +226,7 @@ for $adts.list -> $t
     default { "Poly \"$_\"" }
   };
   say "  kind = $kind;";
-  say "  name = \"$t<name>\";";
+  say "  declaration_name = \"$t<name>\";";
   print "  ctors_or_fields = [ ";
   for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
   say "];";
@@ -237,43 +234,43 @@ for $adts.list -> $t
   say "";
   # TODO: factor out some of the common bits here.
   say "and continue_info_$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun visitor x ->";
+  say '{';
+  say "  instance_declaration_name = \"$t<name>\";";
   do given $t<kind> {
     when $record {
-        say 'Record {';
-        say "  name = \"$t<name>\";";
-        print "  fields = [ ";
+        say '  instance_kind = RecordInstance {';
+        print "    fields = [ ";
         for $t<ctorsOrFields>.list -> $c { print "continue_info_$t<name>_$c<name> visitor x.$c<name> ; "; }
-        say "];";
-        say '}';
+        say "  ];";
+        say '};';
     }
     when $variant {
-        say 'Variant {';
-        say "  name = \"$t<name>\";";
-        say "  constructor = (match x with";
+        say '  instance_kind = VariantInstance {';
+        say "    constructor = (match x with";
         for $t<ctorsOrFields>.list -> $c { say "    | $c<name> v -> continue_info_$t<name>_$c<name> visitor v"; }
         say "  );";
-        print "  variant = [ ";
+        print "    variant = [ ";
         for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
         say "];";
-        say '}'
+        say '};';
     }
     default {
-        say 'Poly {';
-        say "  name = \"$t<name>\";";
-        say "  type_ = \"$_\";";
-        print "  arguments = [";
+        say '  instance_kind = PolyInstance {';
+        say "    poly = \"$_\";";
+        print "    arguments = [";
         # TODO: sort by c<name> (currently we only have one-argument
         # polymorphic types so it happens to work but should be fixed.
         for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
         say "];";
-        print "  continue = (fun state -> visitor.$_ visitor x (";
+        print "    poly_continue = (fun state -> visitor.$_ visitor x (";
         print $t<ctorsOrFields>
-            .map(-> $c { "(fun state x -> (continue_info_$t<name>_$c<name> visitor x).continue state)" })
+            .map(-> $c { "(fun state x -> (continue_info_$t<name>_$c<name> visitor x).cf_continue state)" })
             .join(", ");
         say ") state);";
-        say '}';
+        say '};';
     }
   };
+  say '}';
   say ""; }
 
 # make the "continue" object
@@ -310,18 +307,20 @@ say "";
 for $adts.list -> $t
 { say "and fold_$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate -> qstate = fun visitor x state ->";
   # TODO: add a non-generic continue_fold.
-  say "  let node_info : qstate Adt_info.node_info = fun () -> whole_adt_info (), continue_info_$t<name> visitor x in";
+  say '  let node_instance_info : qstate Adt_info.node_instance_info = {';
+  say "    adt = whole_adt_info () ;";
+  say "    node_instance = continue_info_$t<name> visitor x";
+  say '  } in';
   # say "  let (new_x, state) = visitor.$t<name> x (fun () -> whole_adt_info, info_$t<name>) state continue_fold in";
-  say "  let state = visitor.generic node_info state in";
-  say "  state";
+  say "  visitor.generic node_instance_info state";
   say "";
   for $t<ctorsOrFields>.list -> $c
   { say "and fold_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate -> qstate = fun visitor x state ->";
-    # say "  let ctor_or_field_info : qstate Adt_info.ctor_or_field_info = fun () -> whole_adt_info (), info_$t<name>, continue_info_$t<name>_$c<name> visitor x in";
+    # 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<isBuiltin>) {
-        say "  let state = (*visitor.generic_ctor_or_field ctor_or_field_info*) visitor.$c<type> visitor x state in";
+        say "  let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) visitor.$c<type> visitor x state in";
     } else {
-        say "  let state = (*visitor.generic_ctor_or_field ctor_or_field_info*) fold_$c<type> visitor x state in";
+        say "  let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold_$c<type> visitor x state in";
     }
     say "  state";
     # say "  visitor.$t<name>_$c<name> x (fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>) state continue_fold";
diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml
index 53704abc8..7defcfbb2 100644
--- a/src/stages/adt_generator/generic.ml
+++ b/src/stages/adt_generator/generic.ml
@@ -1,4 +1,3 @@
-[@@@warning "-30"]
 module Adt_info = struct
   type kind =
   | Record
@@ -6,49 +5,55 @@ module Adt_info = struct
   | Poly of string
 
   type 'state record_instance = {
-    name : string;
-    fields : 'state ctor_or_field_continue list;
+    fields : 'state ctor_or_field_instance list;
   }
+
   and 'state constructor_instance = {
-    name : string;
-    constructor : 'state ctor_or_field_continue ;
+    constructor : 'state ctor_or_field_instance ;
     variant : ctor_or_field list
   }
+
   and 'state poly_instance = {
-    name : string;
-    type_ : string;
+    poly : string;
     arguments : string list;
-    continue : 'state -> 'state
+    poly_continue : 'state -> 'state
+  }
+
+  and 'state kind_instance =
+  | RecordInstance of 'state record_instance
+  | VariantInstance of 'state constructor_instance
+  | PolyInstance of 'state poly_instance
+
+  and 'state instance = {
+    instance_declaration_name : string;
+    instance_kind : 'state kind_instance;
   }
-  and 'state instance =
-  | Record of 'state record_instance
-  | Variant of 'state constructor_instance
-  | Poly of 'state poly_instance
 
   and ctor_or_field =
     {
       name : string;
-      isBuiltin : bool;
+      is_builtin : bool;
       type_ : string;
     }
 
-  and 'state ctor_or_field_continue =
+  and 'state ctor_or_field_instance =
     {
-      name : string;
-      isBuiltin : bool;
-      type_ : string;
-      continue : 'state -> 'state
+      cf : ctor_or_field;
+      cf_continue : 'state -> 'state
     }
 
   type node =
     {
       kind : kind;
-      name : string;
+      declaration_name : string;
       ctors_or_fields : ctor_or_field list;
     }
 
   (* TODO: rename things a bit in this file. *)
   type adt = node list
-  type 'state node_info = unit -> adt * 'state instance
-  type 'state ctor_or_field_info = unit -> adt * node * 'state ctor_or_field_continue
+  type 'state node_instance_info = {
+    adt           : adt ;
+    node_instance : 'state instance ;
+  }
+  type 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
 end
diff --git a/src/stages/adt_generator/use_a_fold.ml b/src/stages/adt_generator/use_a_fold.ml
index d5225092c..c62c38e0f 100644
--- a/src/stages/adt_generator/use_a_fold.ml
+++ b/src/stages/adt_generator/use_a_fold.ml
@@ -54,15 +54,15 @@ let () =
   let op = {
       generic = (fun info state ->
         assert_nostate state;
-        match info () with
-        | (_, Adt_info.Record { name=_; fields }) ->
-           false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_continue) -> fld.name ^ " = " ^ snd (fld.continue nostate)) fields) ^ " }"
-        | (_, Adt_info.Variant { name=_; constructor={ name; isBuiltin=_; type_=_; continue }; variant=_ }) ->
-           (match continue nostate with
+        match info.node_instance.instance_kind with
+        | RecordInstance { fields } ->
+           false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
+        | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue }; variant=_ } ->
+           (match cf_continue nostate with
             | true,  arg -> true, name ^ " (" ^ arg ^ ")"
             | false, arg -> true, name ^ " "  ^ arg)
-        | (_, Adt_info.Poly { name=_; type_=_; arguments=_; continue }) ->
-           (continue nostate)
+        | PolyInstance { poly=_; arguments=_; poly_continue } ->
+           (poly_continue nostate)
       );
       string = (fun _visitor str state -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
       unit = (fun _visitor () state -> assert_nostate state; false , "()") ;