ADT generator: Parser for OCaml ADTs, WIP on adding info

src/stages/adt_generator/adt_generator.ml

@@ -1,2 +1,2 @@
-module A = A
+module Amodule = Amodule
 module Use_a_fold = Use_a_fold

src/stages/adt_generator/amodule.ml

@@ -0,0 +1,21 @@
+type root =
+| A of rootA
+| B of rootB
+| C of string
+
+and a = {
+  a1 : ta1 ;
+  a2 : ta2 ;
+}
+
+and ta1 =
+| X of root
+| Y of ta2
+
+and ta2 =
+| Z of ta2
+| W of unit
+
+and rootA = a list
+
+and rootB = int list

src/stages/adt_generator/amodule_utils.ml

@@ -1,27 +1,3 @@
-type root =
-| A of rootA
-| B of rootB
-| C of string
-
-and a = {
-  a1 : ta1 ;
-  a2 : ta2 ;
-}
-
-and ta1 =
-| X of root
-| Y of ta2
-
-and ta2 =
-| Z of ta2
-| W of unit
-
-and rootA =
-  a list
-
-and rootB =
-  int list
-
 let fold_list v state continue =
   let aux = fun (lst', state) elt ->
     let (elt', state) = continue elt state in

src/stages/adt_generator/dune

@@ -1,13 +1,7 @@
-(rule
-  (target generator_fstrings.py)
-  (deps generator.py)
-  (action (with-stdout-to generator_fstrings.py (run sh -c "if python3 -c 'f\"\"' 2>/dev/null; then :; else echo '# -*- coding: future_fstrings -*-'; fi; cat generator.py")))
-)
-
 (rule
   (target generated_fold.ml)
-  (deps generator_fstrings.py)
+  (deps generator.raku)
-  (action (with-stdout-to generated_fold.ml (run python3 ./generator_fstrings.py)))
+  (action (with-stdout-to generated_fold.ml (run perl6 ./generator.raku amodule.ml)))
   (mode (promote (until-clean)))
 )
 ; (library

src/stages/adt_generator/generator.raku

@@ -4,56 +4,116 @@ use v6;
 use v6.c;
 use worries;
 
-
+my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_");
-my $moduleName = "A";
 my $variant = "_ _variant";
 my $record = "_ _ record";
 sub poly { $^type_name }
-my @adts_raw = [
+
-    # typename, kind, fields_or_ctors
+my $l = @*ARGS[0].IO.lines;
-    ["root", $variant, [
+$l = $l.map(*.subst: /^\s+/, "");
-         # ctor, builtin?, type
+$l = $l.cache.map(*.subst: /^type\s+/, "\nand ");
-         ["A", False, "rootA"],
+$l = $l.join("\n").split(/\nand\s+/).grep(/./);
-         ["B", False, "rootB"],
+$l = $l.map(*.split("\n"));
-         ["C", True, "string"],
+$l = $l.map: {
-     ]],
+    my $ll = $_;
-    ["a", $record, [
+    my ($name, $kind) = do given $_[0] {
-         # field, builtin?, type
+        when /^(\w+)\s*\=$/   { "$/[0]", $variant }
-         ["a1", False, "ta1"],
+        when /^(\w+)\s*\=\s*\{$/ { "$/[0]", $record }
-         ["a2", False, "ta2"],
+        when /^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ { "$/[0]", poly("$/[2]") }
-     ]],
+        default { die "Syntax error when parsing header:" ~ $ll.perl ~ "\n$_" }
-    ["ta1", $variant, [
+    };
-         ["X", False, "root"],
+    my $ctorsOrFields = do {
-         ["Y", False, "ta2"],
+        when (/^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
-     ]],
+        default {
-    ["ta2", $variant, [
+            $_[1..*].grep({ ! /^\}?$/ }).map: {
-         ["Z", False, "ta2"],
+                when /^\|\s*(\w+)\s*of\s+((\'|\w)+)$/ { "$/[0]", "$/[1]" }
-         ["W", True, "unit"],
+                when /^(\w+)\s*\:\s*((\'|\w)+)\s*\;$/ { "$/[0]", "$/[1]" }
-     ]],
+                default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" }
-    # polymorphic type
+            }
-    ["rootA", poly("list"),
+        };
-     [
+    }
-      # Position (0..n-1), builtin?, type argument
+    %{
-      [0, False, "a"],
+      "name"          => $name ,
-     ],
+      "kind"          => $kind ,
-    ],
+      "ctorsOrFields" => $ctorsOrFields
-    ["rootB", poly("list"),
+    }
-     [
+    # $_[0].subst: , '' }
-      # Position (0..n-1), builtin?, type argument
+};
-      [0, True, "int"],
+# $l.perl.say;
-     ],
+# exit;
-    ],
+
-    ];
+# ($cf, $isBuiltin, $type) 
+       # {
+       #     name      => $cf ,
+       #     newName   => "$cf'" ,
+       #     isBuiltin => $isBuiltin ,
+       #     type      => $type ,
+       #     newType   => $isBuiltin ?? $type !! "$type'"
+       # }
 
 
 
-# say $adts_raw.perl;
+# my @adts_raw = [
-my $adts = (map -> ($name , $kind, @ctorsOrFields) {
+#     # typename, kind, fields_or_ctors
+#     ["root", $variant, [
+#          # ctor, builtin?, type
+#          ["A", False, "rootA"],
+#          ["B", False, "rootB"],
+#          ["C", True, "string"],
+#      ]],
+#     ["a", $record, [
+#          # field, builtin?, type
+#          ["a1", False, "ta1"],
+#          ["a2", False, "ta2"],
+#      ]],
+#     ["ta1", $variant, [
+#          ["X", False, "root"],
+#          ["Y", False, "ta2"],
+#      ]],
+#     ["ta2", $variant, [
+#          ["Z", False, "ta2"],
+#          ["W", True, "unit"],
+#      ]],
+#     # polymorphic type
+#     ["rootA", poly("list"),
+#      [
+#       # Position (0..n-1), builtin?, type argument
+#       [0, False, "a"],
+#      ],
+#     ],
+#     ["rootB", poly("list"),
+#      [
+#       # Position (0..n-1), builtin?, type argument
+#       [0, True, "int"],
+#      ],
+#     ],
+#     ];
+
+# # say $adts_raw.perl;
+# my $adts = (map -> ($name , $kind, @ctorsOrFields) {
+#   {
+#    "name"          => $name ,
+#    "newName"       => "$name'" ,
+#    "kind"          => $kind ,
+#    "ctorsOrFields" => @(map -> ($cf, $isBuiltin, $type) {
+#        {
+#            name      => $cf ,
+#            newName   => "$cf'" ,
+#            isBuiltin => $isBuiltin ,
+#            type      => $type ,
+#            newType   => $isBuiltin ?? $type !! "$type'"
+#        }
+#    }, @ctorsOrFields),
+#   }
+# }, @adts_raw).list;
+
+my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
   {
    "name"          => $name ,
    "newName"       => "$name'" ,
    "kind"          => $kind ,
-   "ctorsOrFields" => @(map -> ($cf, $isBuiltin, $type) {
+   "ctorsOrFields" => @(map -> ($cf, $type) {
+       my $isBuiltin = ! $l.cache.first({ $_<name> eq $type });
        {
            name      => $cf ,
            newName   => "$cf'" ,
@@ -63,7 +123,9 @@ my $adts = (map -> ($name , $kind, @ctorsOrFields) {
        }
    }, @ctorsOrFields),
   }
-}, @adts_raw).list;
+}, @$l.cache).list;
+
+# say $adts.perl;
 
 # say $adts.perl ;
 
@@ -71,6 +133,7 @@ say "(* This is an auto-generated file. Do not edit. *)";
 
 say "";
 say "open $moduleName";
+say "open {$moduleName}_utils";
 
 say "";
 for $adts.kv -> $index, $t {
@@ -93,6 +156,33 @@ for $adts.kv -> $index, $t {
   }
 }
 
+say "";
+say "module Adt_info = struct";
+say "  type kind =";
+say "  | Record";
+say "  | Variant";
+say "  | Poly of string";
+say "";
+say "  type ctor_or_field =";
+say '    {';
+say "      name : string;";
+say "      isBuiltin : bool;";
+say "      type_ : string;";
+say '    }';
+say "";
+say "  type node =";
+say '    {';
+say "      kind : kind;";
+say "      name : string;";
+say "      ctors_or_fields : ctor_or_field list;";
+say '    }';
+say "";
+say "  type adt = node list";
+say "  type node_info = unit -> adt * node";
+say "  type ctor_or_field_info = unit -> adt * node";
+say "end";
+
+
 say "";
 say "type 'state continue_fold =";
 say '  {';
@@ -106,11 +196,11 @@ say "";
 say "type 'state fold_config =";
 say '  {';
 for $adts.list -> $t
-{ say "    $t<name> : $t<name> -> 'state -> ('state continue_fold) -> ($t<newName> * 'state) ;";
+{ say "    $t<name> : $t<name> -> Adt_info.node_info -> 'state -> ('state continue_fold) -> ($t<newName> * 'state) ;";
-  say "    $t<name>_pre_state : $t<name> -> 'state -> 'state ;";
+  say "    $t<name>_pre_state : $t<name> -> Adt_info.node_info -> 'state -> 'state ;";
-  say "    $t<name>_post_state : $t<name> -> $t<newName> -> 'state -> 'state ;";
+  say "    $t<name>_post_state : $t<name> -> $t<newName> -> Adt_info.node_info -> 'state -> 'state ;";
   for $t<ctorsOrFields>.list -> $c
-  { say "    $t<name>_$c<name> : $c<type> -> 'state -> ('state continue_fold) -> ($c<newType> * 'state) ;";
+  { say "    $t<name>_$c<name> : $c<type> -> Adt_info.ctor_or_field_info -> 'state -> ('state continue_fold) -> ($c<newType> * 'state) ;";
   } }
 say '  }';
 
@@ -128,20 +218,20 @@ say "";
 for $adts.list -> $t
 { say "and fold_$t<name> : type state . state fold_config -> $t<name> -> state -> ($t<newName> * state) = fun visitor x state ->";
   say "  let continue_fold : state continue_fold = mk_continue_fold visitor in";
-  say "  let state = visitor.$t<name>_pre_state x state in";
+  say "  let state = visitor.$t<name>_pre_state x (fun () -> failwith \"todo\") state in";
-  say "  let (new_x, state) = visitor.$t<name> x state continue_fold in";
+  say "  let (new_x, state) = visitor.$t<name> x (fun () -> failwith \"todo\") state continue_fold in";
-  say "  let state = visitor.$t<name>_post_state x new_x state in";
+  say "  let state = visitor.$t<name>_post_state x new_x (fun () -> failwith \"todo\") state in";
   say "  (new_x, state)";
   say "";
   for $t<ctorsOrFields>.list -> $c
   { say "and fold_$t<name>_$c<name> : type state . state fold_config -> $c<type> -> state -> ($c<newType> * state) = fun visitor x state ->";
     say "  let continue_fold : state continue_fold = mk_continue_fold visitor in";
-    say "  visitor.$t<name>_$c<name> x state continue_fold";
+    say "  visitor.$t<name>_$c<name> x (fun () -> failwith \"todo\") state continue_fold";
     say ""; } }
 
 say "let no_op : 'a fold_config = \{";
 for $adts.list -> $t
-{ say "  $t<name> = (fun v state continue ->";
+{ say "  $t<name> = (fun v _info state continue ->";
   say "    match v with";
   if ($t<kind> eq $variant) {
     for $t<ctorsOrFields>.list -> $c
@@ -163,10 +253,10 @@ for $adts.list -> $t
     say " )";
   }
   say "  );";
-  say "  $t<name>_pre_state = (fun v state -> ignore v; state) ;";
+  say "  $t<name>_pre_state = (fun v _info state -> ignore v; state) ;";
-  say "  $t<name>_post_state = (fun v new_v state -> ignore (v, new_v); state) ;";
+  say "  $t<name>_post_state = (fun v new_v _info state -> ignore (v, new_v); state) ;";
   for $t<ctorsOrFields>.list -> $c
-  { print "  $t<name>_$c<name> = (fun v state continue -> ";
+  { print "  $t<name>_$c<name> = (fun v _info state continue -> ";
     if ($c<isBuiltin>) {
       print "ignore continue; (v, state)";
     } else {

src/stages/adt_generator/use_a_fold.ml

@@ -1,4 +1,4 @@
-open A
+open Amodule
 open Fold
 
 (* TODO: how should we plug these into our test framework? *)
@@ -7,7 +7,7 @@ let () =
   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 = fun the_a state continue_fold ->
+      a = fun the_a _info state continue_fold ->
           let (a1' , state') = continue_fold.ta1 the_a.a1 state in
           let (a2' , state'') = continue_fold.ta2 the_a.a2 state' in
           ({
@@ -24,7 +24,7 @@ let () =
 
 let () =
   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_pre_state = fun _the_a state -> state + 1 } in
+  let op = { no_op with a_pre_state = fun _the_a _info state -> state + 1 } in
   let state = 0 in
   let (_, state) = fold_root op some_root state in
   if state != 2 then
@@ -34,7 +34,7 @@ let () =
 
 let () =
   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_post_state = fun _the_a _new_a state -> state + 1 } in
+  let op = { no_op with a_post_state = fun _the_a _new_a _info state -> state + 1 } in
   let state = 0 in
   let (_, state) = fold_root op some_root state in
   if state != 2 then