From 20a51381bcca119288c1324ca8d1742e65e25dee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 3 Mar 2020 22:02:55 +0100 Subject: [PATCH] ADT generator: Parser for OCaml ADTs, WIP on adding info --- src/stages/adt_generator/adt_generator.ml | 2 +- src/stages/adt_generator/amodule.ml | 21 ++ .../adt_generator/{a.ml => amodule_utils.ml} | 24 --- src/stages/adt_generator/dune | 10 +- src/stages/adt_generator/generator.raku | 196 +++++++++++++----- src/stages/adt_generator/use_a_fold.ml | 8 +- 6 files changed, 171 insertions(+), 90 deletions(-) create mode 100644 src/stages/adt_generator/amodule.ml rename src/stages/adt_generator/{a.ml => amodule_utils.ml} (57%) diff --git a/src/stages/adt_generator/adt_generator.ml b/src/stages/adt_generator/adt_generator.ml index 9c1ff4b88..840fe1b02 100644 --- a/src/stages/adt_generator/adt_generator.ml +++ b/src/stages/adt_generator/adt_generator.ml @@ -1,2 +1,2 @@ -module A = A +module Amodule = Amodule module Use_a_fold = Use_a_fold diff --git a/src/stages/adt_generator/amodule.ml b/src/stages/adt_generator/amodule.ml new file mode 100644 index 000000000..8de6bdb5e --- /dev/null +++ b/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 diff --git a/src/stages/adt_generator/a.ml b/src/stages/adt_generator/amodule_utils.ml similarity index 57% rename from src/stages/adt_generator/a.ml rename to src/stages/adt_generator/amodule_utils.ml index 34b611dc1..d22073d78 100644 --- a/src/stages/adt_generator/a.ml +++ b/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 diff --git a/src/stages/adt_generator/dune b/src/stages/adt_generator/dune index 0c9b430b6..9b210a52f 100644 --- a/src/stages/adt_generator/dune +++ b/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) - (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 diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index e4912da3f..7f5d6b797 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -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({ $_ 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 : $t -> 'state -> ('state continue_fold) -> ($t * 'state) ;"; - say " $t_pre_state : $t -> 'state -> 'state ;"; - say " $t_post_state : $t -> $t -> 'state -> 'state ;"; +{ say " $t : $t -> Adt_info.node_info -> 'state -> ('state continue_fold) -> ($t * 'state) ;"; + say " $t_pre_state : $t -> Adt_info.node_info -> 'state -> 'state ;"; + say " $t_post_state : $t -> $t -> Adt_info.node_info -> 'state -> 'state ;"; for $t.list -> $c - { say " $t_$c : $c -> 'state -> ('state continue_fold) -> ($c * 'state) ;"; + { say " $t_$c : $c -> Adt_info.ctor_or_field_info -> 'state -> ('state continue_fold) -> ($c * 'state) ;"; } } say ' }'; @@ -128,20 +218,20 @@ say ""; for $adts.list -> $t { say "and fold_$t : type state . state fold_config -> $t -> state -> ($t * state) = fun visitor x state ->"; say " let continue_fold : state continue_fold = mk_continue_fold visitor in"; - say " let state = visitor.$t_pre_state x state in"; - say " let (new_x, state) = visitor.$t x state continue_fold in"; - say " let state = visitor.$t_post_state x new_x state in"; + say " let state = visitor.$t_pre_state x (fun () -> failwith \"todo\") state in"; + say " let (new_x, state) = visitor.$t x (fun () -> failwith \"todo\") state continue_fold in"; + say " let state = visitor.$t_post_state x new_x (fun () -> failwith \"todo\") state in"; say " (new_x, state)"; say ""; for $t.list -> $c { say "and fold_$t_$c : type state . state fold_config -> $c -> state -> ($c * state) = fun visitor x state ->"; say " let continue_fold : state continue_fold = mk_continue_fold visitor in"; - say " visitor.$t_$c x state continue_fold"; + say " visitor.$t_$c x (fun () -> failwith \"todo\") state continue_fold"; say ""; } } say "let no_op : 'a fold_config = \{"; for $adts.list -> $t -{ say " $t = (fun v state continue ->"; +{ say " $t = (fun v _info state continue ->"; say " match v with"; if ($t eq $variant) { for $t.list -> $c @@ -163,10 +253,10 @@ for $adts.list -> $t say " )"; } say " );"; - say " $t_pre_state = (fun v state -> ignore v; state) ;"; - say " $t_post_state = (fun v new_v state -> ignore (v, new_v); state) ;"; + say " $t_pre_state = (fun v _info state -> ignore v; state) ;"; + say " $t_post_state = (fun v new_v _info state -> ignore (v, new_v); state) ;"; for $t.list -> $c - { print " $t_$c = (fun v state continue -> "; + { print " $t_$c = (fun v _info state continue -> "; if ($c) { print "ignore continue; (v, state)"; } else { diff --git a/src/stages/adt_generator/use_a_fold.ml b/src/stages/adt_generator/use_a_fold.ml index 0fe476d42..5033da391 100644 --- a/src/stages/adt_generator/use_a_fold.ml +++ b/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