ADT generator: Parser for OCaml ADTs, WIP on adding info
This commit is contained in:
Suzanne Dupéron
parent
e92ba202cf
commit
20a51381bc
@ -1,2 +1,2 @@
|
||||
module A = A
|
||||
module Amodule = Amodule
|
||||
module Use_a_fold = Use_a_fold
|
||||
|
||||
21
src/stages/adt_generator/amodule.ml
Normal file
21
src/stages/adt_generator/amodule.ml
Normal file
@ -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
|
||||
@ -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
|
||||
@ -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)
|
||||
(action (with-stdout-to generated_fold.ml (run python3 ./generator_fstrings.py)))
|
||||
(deps generator.raku)
|
||||
(action (with-stdout-to generated_fold.ml (run perl6 ./generator.raku amodule.ml)))
|
||||
(mode (promote (until-clean)))
|
||||
)
|
||||
; (library
|
||||
|
||||
@ -4,56 +4,116 @@ use v6;
|
||||
use v6.c;
|
||||
use worries;
|
||||
|
||||
|
||||
my $moduleName = "A";
|
||||
my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_");
|
||||
my $variant = "_ _variant";
|
||||
my $record = "_ _ record";
|
||||
sub poly { $^type_name }
|
||||
my @adts_raw = [
|
||||
# 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"],
|
||||
],
|
||||
],
|
||||
];
|
||||
|
||||
my $l = @*ARGS[0].IO.lines;
|
||||
$l = $l.map(*.subst: /^\s+/, "");
|
||||
$l = $l.cache.map(*.subst: /^type\s+/, "\nand ");
|
||||
$l = $l.join("\n").split(/\nand\s+/).grep(/./);
|
||||
$l = $l.map(*.split("\n"));
|
||||
$l = $l.map: {
|
||||
my $ll = $_;
|
||||
my ($name, $kind) = do given $_[0] {
|
||||
when /^(\w+)\s*\=$/ { "$/[0]", $variant }
|
||||
when /^(\w+)\s*\=\s*\{$/ { "$/[0]", $record }
|
||||
when /^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ { "$/[0]", poly("$/[2]") }
|
||||
default { die "Syntax error when parsing header:" ~ $ll.perl ~ "\n$_" }
|
||||
};
|
||||
my $ctorsOrFields = do {
|
||||
when (/^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
|
||||
default {
|
||||
$_[1..*].grep({ ! /^\}?$/ }).map: {
|
||||
when /^\|\s*(\w+)\s*of\s+((\'|\w)+)$/ { "$/[0]", "$/[1]" }
|
||||
when /^(\w+)\s*\:\s*((\'|\w)+)\s*\;$/ { "$/[0]", "$/[1]" }
|
||||
default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" }
|
||||
}
|
||||
};
|
||||
}
|
||||
%{
|
||||
"name" => $name ,
|
||||
"kind" => $kind ,
|
||||
"ctorsOrFields" => $ctorsOrFields
|
||||
}
|
||||
# $_[0].subst: , '' }
|
||||
};
|
||||
# $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 = (map -> ($name , $kind, @ctorsOrFields) {
|
||||
# my @adts_raw = [
|
||||
# # 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>_pre_state : $t<name> -> 'state -> 'state ;";
|
||||
say " $t<name>_post_state : $t<name> -> $t<newName> -> 'state -> 'state ;";
|
||||
{ say " $t<name> : $t<name> -> Adt_info.node_info -> 'state -> ('state continue_fold) -> ($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 ;";
|
||||
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 (new_x, state) = visitor.$t<name> x state continue_fold in";
|
||||
say " let state = visitor.$t<name>_post_state x new_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 (fun () -> failwith \"todo\") state continue_fold 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>_post_state = (fun v new_v state -> ignore (v, new_v); state) ;";
|
||||
say " $t<name>_pre_state = (fun v _info state -> ignore 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 {
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user