Merge branch 'feature/adt-generator-7-run-dev' into 'dev'
ADT generator: auto-generate folds over ADTs See merge request ligolang/ligo!480
This commit is contained in:
commit
ed3343cd76
@ -29,7 +29,7 @@ RUN opam update
|
||||
|
||||
# Install ligo
|
||||
RUN sh scripts/install_vendors_deps.sh
|
||||
RUN opam install -y .
|
||||
RUN opam install -y . || (tail -n +1 ~/.opam/log/* ; false)
|
||||
|
||||
# Use the ligo binary as a default command
|
||||
ENTRYPOINT [ "/home/opam/.opam/4.07/bin/ligo" ]
|
||||
|
@ -1,5 +1,6 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
if test $# -ne 1 || test "x$1" = "-h" -o "x$1" = "x--help"; then
|
||||
echo "Usage: build_docker_image.sh TAG_NAME"
|
||||
|
@ -1,5 +1,6 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
eval $(opam config env)
|
||||
dune build -p ligo
|
||||
|
@ -1,4 +1,6 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
dockerfile_name="build"
|
||||
# Generic dockerfile
|
||||
|
@ -1,4 +1,6 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
dockerfile_name="package"
|
||||
dockerfile=""
|
||||
|
@ -1,11 +1,15 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
# This script accepts three arguments, os family, os and its version,
|
||||
# which are subsequently used to fetch the respective docker
|
||||
# image from the ocaml/infrastructure project.
|
||||
#
|
||||
# https://github.com/ocaml/infrastructure/wiki/Containers#selecting-linux-distributions
|
||||
target_os_family=$1
|
||||
target_os=$2
|
||||
target_os_version=$3
|
||||
target_os_family="$1"
|
||||
target_os="$2"
|
||||
target_os_version="$3"
|
||||
|
||||
# Variables configured at the CI level
|
||||
dist="$LIGO_DIST_DIR"
|
||||
@ -29,4 +33,4 @@ fi
|
||||
target_os_specific_dockerfile="./docker/distribution/$target_os_family/$target_os/$dockerfile_name.Dockerfile"
|
||||
if test -f "$target_os_specific_dockerfile"; then
|
||||
dockerfile="$target_os_specific_dockerfile"
|
||||
fi
|
||||
fi
|
||||
|
@ -22,26 +22,29 @@ echo "Installing dependencies.."
|
||||
if [ -n "`uname -a | grep -i arch`" ]
|
||||
then
|
||||
sudo pacman -Sy --noconfirm \
|
||||
rakudo \
|
||||
make \
|
||||
m4 \
|
||||
gcc \
|
||||
patch \
|
||||
bubblewrap \
|
||||
rsync \
|
||||
curl
|
||||
curl
|
||||
fi
|
||||
|
||||
if [ -n "`uname -a | grep -i ubuntu`" ]
|
||||
then
|
||||
sudo apt-get install -y make \
|
||||
perl6 \
|
||||
make \
|
||||
m4 \
|
||||
gcc \
|
||||
patch \
|
||||
bubblewrap \
|
||||
rsync \
|
||||
curl
|
||||
curl
|
||||
fi
|
||||
|
||||
|
||||
if [ -n "`uname -a | grep -i ubuntu`" ]
|
||||
then
|
||||
echo "ubuntu"
|
||||
|
@ -1,11 +1,13 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
. /etc/os-release
|
||||
|
||||
if [ $ID = arch ]
|
||||
then
|
||||
pacman -Sy
|
||||
sudo pacman -S --noconfirm \
|
||||
rakudo \
|
||||
libevdev \
|
||||
perl \
|
||||
pkg-config \
|
||||
@ -20,6 +22,7 @@ then
|
||||
else
|
||||
apt-get update -qq
|
||||
apt-get -y -qq install \
|
||||
perl6 \
|
||||
libev-dev \
|
||||
perl \
|
||||
pkg-config \
|
||||
|
@ -1,5 +1,6 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
# Install local dependencies
|
||||
opam install -y --deps-only --with-test ./ligo.opam $(find vendors -name \*.opam)
|
||||
|
@ -567,7 +567,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
||||
let wtype = Format.asprintf
|
||||
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in
|
||||
fail @@ simple_error wtype in
|
||||
let lname = lname in
|
||||
let e' = Environment.add_ez_binder lname input_type e in
|
||||
let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
|
||||
let output_type = body.type_expression in
|
||||
|
@ -106,7 +106,6 @@ and ascription = {
|
||||
type_annotation: type_expression ;
|
||||
}
|
||||
|
||||
|
||||
and environment_element_definition =
|
||||
| ED_binder
|
||||
| ED_declaration of environment_element_definition_declaration
|
||||
|
2
src/stages/adt_generator/.gitignore
vendored
Normal file
2
src/stages/adt_generator/.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
# This is an auto-generated test file
|
||||
/generated_fold.ml
|
@ -1,7 +1,7 @@
|
||||
Build with:
|
||||
Build & test with:
|
||||
|
||||
dune build adt_generator.a
|
||||
dune build adt_generator.exe && ../../../_build/default/src/stages/adt_generator/adt_generator.exe
|
||||
|
||||
Run with
|
||||
|
||||
python ./generator.py
|
||||
perl6 ./generator.raku amodule.ml
|
||||
|
@ -1,2 +1,2 @@
|
||||
module A = A
|
||||
module Amodule = Amodule
|
||||
module Use_a_fold = Use_a_fold
|
||||
|
@ -1,6 +1,6 @@
|
||||
type root =
|
||||
| A of a
|
||||
| B of int
|
||||
| A of rootA
|
||||
| B of rootB
|
||||
| C of string
|
||||
|
||||
and a = {
|
||||
@ -15,3 +15,7 @@ and ta1 =
|
||||
and ta2 =
|
||||
| Z of ta2
|
||||
| W of unit
|
||||
|
||||
and rootA = a list
|
||||
|
||||
and rootB = int list
|
10
src/stages/adt_generator/amodule_utils.ml
Normal file
10
src/stages/adt_generator/amodule_utils.ml
Normal file
@ -0,0 +1,10 @@
|
||||
let fold_map_list v state continue =
|
||||
let aux = fun (lst', state) elt ->
|
||||
let (elt', state) = continue elt state in
|
||||
(elt' :: lst' , state) in
|
||||
List.fold_left aux ([], state) v
|
||||
|
||||
let fold_map_option v state continue =
|
||||
match v with
|
||||
Some x -> continue x state
|
||||
| None -> None
|
@ -1,8 +1,9 @@
|
||||
(rule
|
||||
(target fold.ml)
|
||||
(deps generator.py)
|
||||
(action (with-stdout-to fold.ml (run python3 ./generator.py)))
|
||||
(mode (promote (until-clean))))
|
||||
(target generated_fold.ml)
|
||||
(deps generator.raku)
|
||||
(action (with-stdout-to generated_fold.ml (run perl6 ./generator.raku amodule.ml)))
|
||||
; (mode (promote (until-clean)))
|
||||
)
|
||||
; (library
|
||||
; (name adt_generator)
|
||||
; (public_name ligo.adt_generator)
|
||||
@ -16,3 +17,8 @@
|
||||
(libraries
|
||||
)
|
||||
)
|
||||
|
||||
(alias
|
||||
(name runtest)
|
||||
(action (run ./adt_generator.exe))
|
||||
)
|
||||
|
@ -1,184 +1 @@
|
||||
open A
|
||||
|
||||
type root' =
|
||||
| A' of a'
|
||||
| B' of int
|
||||
| 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
|
||||
|
||||
type 'state continue_fold =
|
||||
{
|
||||
root : root -> 'state -> (root' * 'state) ;
|
||||
root_A : a -> 'state -> (a' * 'state) ;
|
||||
root_B : int -> 'state -> (int * 'state) ;
|
||||
root_C : string -> 'state -> (string * 'state) ;
|
||||
a : a -> 'state -> (a' * 'state) ;
|
||||
a_a1 : ta1 -> 'state -> (ta1' * 'state) ;
|
||||
a_a2 : ta2 -> 'state -> (ta2' * 'state) ;
|
||||
ta1 : ta1 -> 'state -> (ta1' * 'state) ;
|
||||
ta1_X : root -> 'state -> (root' * 'state) ;
|
||||
ta1_Y : ta2 -> 'state -> (ta2' * 'state) ;
|
||||
ta2 : ta2 -> 'state -> (ta2' * 'state) ;
|
||||
ta2_Z : ta2 -> 'state -> (ta2' * 'state) ;
|
||||
ta2_W : unit -> 'state -> (unit * 'state) ;
|
||||
}
|
||||
|
||||
type 'state fold_config =
|
||||
{
|
||||
root : root -> 'state -> ('state continue_fold) -> (root' * 'state) ;
|
||||
root_pre_state : root -> 'state -> 'state ;
|
||||
root_post_state : root -> root' -> 'state -> 'state ;
|
||||
root_A : a -> 'state -> ('state continue_fold) -> (a' * 'state) ;
|
||||
root_B : int -> 'state -> ('state continue_fold) -> (int * 'state) ;
|
||||
root_C : string -> 'state -> ('state continue_fold) -> (string * 'state) ;
|
||||
a : a -> 'state -> ('state continue_fold) -> (a' * 'state) ;
|
||||
a_pre_state : a -> 'state -> 'state ;
|
||||
a_post_state : a -> a' -> 'state -> 'state ;
|
||||
a_a1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ;
|
||||
a_a2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||
ta1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ;
|
||||
ta1_pre_state : ta1 -> 'state -> 'state ;
|
||||
ta1_post_state : ta1 -> ta1' -> 'state -> 'state ;
|
||||
ta1_X : root -> 'state -> ('state continue_fold) -> (root' * 'state) ;
|
||||
ta1_Y : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||
ta2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||
ta2_pre_state : ta2 -> 'state -> 'state ;
|
||||
ta2_post_state : ta2 -> ta2' -> 'state -> 'state ;
|
||||
ta2_Z : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ;
|
||||
ta2_W : unit -> 'state -> ('state continue_fold) -> (unit * 'state) ;
|
||||
}
|
||||
|
||||
(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)
|
||||
let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->
|
||||
{
|
||||
root = fold_root visitor ;
|
||||
root_A = fold_root_A visitor ;
|
||||
root_B = fold_root_B visitor ;
|
||||
root_C = fold_root_C visitor ;
|
||||
a = fold_a visitor ;
|
||||
a_a1 = fold_a_a1 visitor ;
|
||||
a_a2 = fold_a_a2 visitor ;
|
||||
ta1 = fold_ta1 visitor ;
|
||||
ta1_X = fold_ta1_X visitor ;
|
||||
ta1_Y = fold_ta1_Y visitor ;
|
||||
ta2 = fold_ta2 visitor ;
|
||||
ta2_Z = fold_ta2_Z visitor ;
|
||||
ta2_W = fold_ta2_W visitor ;
|
||||
}
|
||||
|
||||
and fold_root : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
let state = visitor.root_pre_state x state in
|
||||
let (new_x, state) = visitor.root x state continue_fold in
|
||||
let state = visitor.root_post_state x new_x state in
|
||||
(new_x, state)
|
||||
|
||||
and fold_root_A : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.root_A x state continue_fold
|
||||
|
||||
and fold_root_B : type state . state fold_config -> int -> state -> (int * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.root_B x state continue_fold
|
||||
|
||||
and fold_root_C : type state . state fold_config -> string -> state -> (string * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.root_C x state continue_fold
|
||||
|
||||
and fold_a : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
let state = visitor.a_pre_state x state in
|
||||
let (new_x, state) = visitor.a x state continue_fold in
|
||||
let state = visitor.a_post_state x new_x state in
|
||||
(new_x, state)
|
||||
|
||||
and fold_a_a1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.a_a1 x state continue_fold
|
||||
|
||||
and fold_a_a2 : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.a_a2 x state continue_fold
|
||||
|
||||
and fold_ta1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
let state = visitor.ta1_pre_state x state in
|
||||
let (new_x, state) = visitor.ta1 x state continue_fold in
|
||||
let state = visitor.ta1_post_state x new_x state in
|
||||
(new_x, state)
|
||||
|
||||
and fold_ta1_X : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.ta1_X x state continue_fold
|
||||
|
||||
and fold_ta1_Y : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.ta1_Y x state continue_fold
|
||||
|
||||
and fold_ta2 : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
let state = visitor.ta2_pre_state x state in
|
||||
let (new_x, state) = visitor.ta2 x state continue_fold in
|
||||
let state = visitor.ta2_post_state x new_x state in
|
||||
(new_x, state)
|
||||
|
||||
and fold_ta2_Z : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.ta2_Z x state continue_fold
|
||||
|
||||
and fold_ta2_W : type state . state fold_config -> unit -> state -> (unit * state) = fun visitor x state ->
|
||||
let continue_fold : state continue_fold = mk_continue_fold visitor in
|
||||
visitor.ta2_W x state continue_fold
|
||||
|
||||
let no_op : 'a fold_config = {
|
||||
root = (fun v state continue ->
|
||||
match v with
|
||||
| A v -> let (v, state) = continue.root_A v state in (A' v, state)
|
||||
| B v -> let (v, state) = continue.root_B v state in (B' v, state)
|
||||
| C v -> let (v, state) = continue.root_C v state in (C' v, state)
|
||||
);
|
||||
root_pre_state = (fun v state -> ignore v; state) ;
|
||||
root_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||
root_A = (fun v state continue -> continue.a v state ) ;
|
||||
root_B = (fun v state continue -> ignore continue; (v, state) ) ;
|
||||
root_C = (fun v state continue -> ignore continue; (v, state) ) ;
|
||||
a = (fun v state continue ->
|
||||
match v with
|
||||
{ a1; a2; } ->
|
||||
let (a1', state) = continue.a_a1 a1 state in
|
||||
let (a2', state) = continue.a_a2 a2 state in
|
||||
({ a1'; a2'; }, state)
|
||||
);
|
||||
a_pre_state = (fun v state -> ignore v; state) ;
|
||||
a_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||
a_a1 = (fun v state continue -> continue.ta1 v state ) ;
|
||||
a_a2 = (fun v state continue -> continue.ta2 v state ) ;
|
||||
ta1 = (fun v state continue ->
|
||||
match v with
|
||||
| X v -> let (v, state) = continue.ta1_X v state in (X' v, state)
|
||||
| Y v -> let (v, state) = continue.ta1_Y v state in (Y' v, state)
|
||||
);
|
||||
ta1_pre_state = (fun v state -> ignore v; state) ;
|
||||
ta1_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||
ta1_X = (fun v state continue -> continue.root v state ) ;
|
||||
ta1_Y = (fun v state continue -> continue.ta2 v state ) ;
|
||||
ta2 = (fun v state continue ->
|
||||
match v with
|
||||
| Z v -> let (v, state) = continue.ta2_Z v state in (Z' v, state)
|
||||
| W v -> let (v, state) = continue.ta2_W v state in (W' v, state)
|
||||
);
|
||||
ta2_pre_state = (fun v state -> ignore v; state) ;
|
||||
ta2_post_state = (fun v new_v state -> ignore (v, new_v); state) ;
|
||||
ta2_Z = (fun v state continue -> continue.ta2 v state ) ;
|
||||
ta2_W = (fun v state continue -> ignore continue; (v, state) ) ;
|
||||
}
|
||||
include Generated_fold
|
||||
|
212
src/stages/adt_generator/generator.pl
Normal file
212
src/stages/adt_generator/generator.pl
Normal file
@ -0,0 +1,212 @@
|
||||
#!/usr/bin/env perl
|
||||
use strict;
|
||||
use warnings;
|
||||
use 5.010;
|
||||
use Data::Dumper; $Data::Dumper::Useqq = 1; # use double quotes when dumping (we have a few "prime'" names)
|
||||
sub enumerate { my $i = 0; [map { [ $i++, $_ ] } @{$_[0]}] }
|
||||
|
||||
my $moduleName = "A";
|
||||
my $variant = "_ _variant";
|
||||
my $record = "_ _ record"; my $true = 1; my $false = 0;
|
||||
sub poly { $_[0] }
|
||||
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 $adts = [map {
|
||||
my ($name , $kind, $ctorsOrFields) = @$_;
|
||||
{
|
||||
"name" => $name ,
|
||||
"newName" => "${name}'" ,
|
||||
"kind" => $kind ,
|
||||
"ctorsOrFields" => [map {
|
||||
my ($cf, $isBuiltin, $type) = @$_;
|
||||
{
|
||||
name => $cf ,
|
||||
newName => "${cf}'" ,
|
||||
isBuiltin => $isBuiltin ,
|
||||
type => $type ,
|
||||
newType => $isBuiltin ? $type : "${type}'"
|
||||
}
|
||||
} @$ctorsOrFields],
|
||||
}
|
||||
} @$adts_raw];
|
||||
|
||||
# print Dumper $adts ;
|
||||
|
||||
say "(* This is an auto-generated file. Do not edit. *)";
|
||||
|
||||
say "";
|
||||
say "open ${moduleName}";
|
||||
|
||||
say "";
|
||||
foreach (@{enumerate($adts)}) {
|
||||
my ($index, $t) = @$_;
|
||||
my %t = %$t;
|
||||
my $typeOrAnd = $index == 0 ? "type" : "and";
|
||||
say "${typeOrAnd} $t{newName} =";
|
||||
if ($t{kind} eq $variant) {
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %c = %$_;
|
||||
say " | $c{newName} of $c{newType}"
|
||||
}
|
||||
}
|
||||
elsif ($t{kind} eq $record) {
|
||||
say " {";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %f = %$_;
|
||||
say " $f{newName} : $f{newType} ;";
|
||||
}
|
||||
say " }";
|
||||
} else {
|
||||
print " ";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %a = %$_;
|
||||
print "$a{newType} ";
|
||||
}
|
||||
print "$t{kind}";
|
||||
say "";
|
||||
}
|
||||
}
|
||||
|
||||
say "";
|
||||
say "type 'state continue_fold =";
|
||||
say " {";
|
||||
foreach (@$adts) {
|
||||
my %t = %$_;
|
||||
say " $t{name} : $t{name} -> 'state -> ($t{newName} * 'state) ;";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %c = %$_;
|
||||
say " $t{name}_$c{name} : $c{type} -> 'state -> ($c{newType} * 'state) ;"
|
||||
}
|
||||
}
|
||||
say " }";
|
||||
|
||||
say "";
|
||||
say "type 'state fold_config =";
|
||||
say " {";
|
||||
foreach (@$adts) {
|
||||
my %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 ;";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %c = %$_;
|
||||
say " $t{name}_$c{name} : $c{type} -> 'state -> ('state continue_fold) -> ($c{newType} * 'state) ;";
|
||||
}
|
||||
}
|
||||
say " }";
|
||||
|
||||
say "";
|
||||
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
|
||||
say "let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->";
|
||||
say " {";
|
||||
foreach (@$adts) {
|
||||
my %t = %$_;
|
||||
say " $t{name} = fold_$t{name} visitor ;";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %c = %$_;
|
||||
say " $t{name}_$c{name} = fold_$t{name}_$c{name} visitor ;";
|
||||
}
|
||||
}
|
||||
say "}";
|
||||
say "";
|
||||
|
||||
foreach (@$adts) {
|
||||
my %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 " (new_x, state)";
|
||||
say "";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %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 "";
|
||||
}
|
||||
}
|
||||
|
||||
say "let no_op : 'a fold_config = {";
|
||||
foreach (@$adts) {
|
||||
my %t = %$_;
|
||||
say " $t{name} = (fun v state continue ->";
|
||||
say " match v with";
|
||||
if ($t{kind} eq $variant) {
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %c = %$_;
|
||||
say " | $c{name} v -> let (v, state) = continue.$t{name}_$c{name} v state in ($c{newName} v, state)";
|
||||
}
|
||||
} elsif ($t{kind} eq $record) {
|
||||
print " { ";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %f = %$_;
|
||||
print "$f{name}; ";
|
||||
}
|
||||
say "} ->";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %f = %$_;
|
||||
say " let ($f{newName}, state) = continue.$t{name}_$f{name} $f{name} state in";
|
||||
}
|
||||
print " ({ ";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %f = %$_;
|
||||
print "$f{newName}; "
|
||||
}
|
||||
say "}, state)";
|
||||
} else {
|
||||
print " v -> fold_$t{kind} v state ( ";
|
||||
print join(", ", map { my %f = %$_; "continue.$t{name}_$f{name}" } @{$t{ctorsOrFields}});
|
||||
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) ;";
|
||||
foreach (@{$t{ctorsOrFields}}) {
|
||||
my %c = %$_;
|
||||
print " $t{name}_$c{name} = (fun v state continue -> ";
|
||||
if ($c{isBuiltin}) {
|
||||
print "ignore continue; (v, state)";
|
||||
} else {
|
||||
print "continue.$c{type} v state";
|
||||
}
|
||||
say ") ;";
|
||||
}
|
||||
}
|
||||
say "}";
|
@ -1,34 +1,56 @@
|
||||
#!/usr/bin/env python3
|
||||
import pprint
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
moduleName = "A"
|
||||
variant="_ _variant"
|
||||
record="_ _record"
|
||||
def poly(x): return x
|
||||
adts = [
|
||||
# typename, variant?, fields_or_ctors
|
||||
("root", True, [
|
||||
# ctor, builtin, type
|
||||
("A", False, "a"),
|
||||
("B", True, "int"),
|
||||
# typename, kind, fields_or_ctors
|
||||
("root", variant, [
|
||||
# ctor, builtin?, type
|
||||
("A", False, "rootA"),
|
||||
("B", False, "rootB"),
|
||||
("C", True, "string"),
|
||||
]),
|
||||
("a", False, [
|
||||
("a", record, [
|
||||
# field, builtin?, type
|
||||
("a1", False, "ta1"),
|
||||
("a2", False, "ta2"),
|
||||
]),
|
||||
("ta1", True, [
|
||||
("ta1", variant, [
|
||||
("X", False, "root"),
|
||||
("Y", False, "ta2"),
|
||||
]),
|
||||
("ta2", True, [
|
||||
("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")
|
||||
]),
|
||||
]
|
||||
|
||||
from collections import namedtuple
|
||||
adt = namedtuple('adt', ['name', 'newName', 'isVariant', 'ctorsOrFields'])
|
||||
adt = namedtuple('adt', ['name', 'newName', 'kind', 'ctorsOrFields'])
|
||||
ctorOrField = namedtuple('ctorOrField', ['name', 'newName', 'isBuiltin', 'type_', 'newType'])
|
||||
adts = [
|
||||
adt(
|
||||
name = name,
|
||||
newName = f"{name}'",
|
||||
isVariant = isVariant,
|
||||
kind = kind,
|
||||
ctorsOrFields = [
|
||||
ctorOrField(
|
||||
name = cf,
|
||||
@ -40,23 +62,34 @@ adts = [
|
||||
for (cf, isBuiltin, type_) in ctors
|
||||
],
|
||||
)
|
||||
for (name, isVariant, ctors) in adts
|
||||
for (name, kind, ctors) in adts
|
||||
]
|
||||
|
||||
# pprint.PrettyPrinter(compact=False, indent=4).pprint(adts)
|
||||
|
||||
print("(* This is an auto-generated file. Do not edit. *)")
|
||||
|
||||
print("")
|
||||
print("open %s" % moduleName)
|
||||
|
||||
print("")
|
||||
for (index, t) in enumerate(adts):
|
||||
typeOrAnd = "type" if index == 0 else "and"
|
||||
print(f"{typeOrAnd} {t.newName} =")
|
||||
if t.isVariant:
|
||||
if t.kind == variant:
|
||||
for c in t.ctorsOrFields:
|
||||
print(f" | {c.newName} of {c.newType}")
|
||||
else:
|
||||
elif t.kind == record:
|
||||
print(" {")
|
||||
for f in t.ctorsOrFields:
|
||||
print(f" {f.newName} : {f.newType} ;")
|
||||
print(" }")
|
||||
else:
|
||||
print(" ", end='')
|
||||
for a in t.ctorsOrFields:
|
||||
print(f"{a.newType}", end=' ')
|
||||
print(t.kind, end='')
|
||||
print("")
|
||||
|
||||
print("")
|
||||
print(f"type 'state continue_fold =")
|
||||
@ -107,10 +140,10 @@ print("let no_op : 'a fold_config = {")
|
||||
for t in adts:
|
||||
print(f" {t.name} = (fun v state continue ->")
|
||||
print(" match v with")
|
||||
if t.isVariant:
|
||||
if t.kind == variant:
|
||||
for c in t.ctorsOrFields:
|
||||
print(f" | {c.name} v -> let (v, state) = continue.{t.name}_{c.name} v state in ({c.newName} v, state)")
|
||||
else:
|
||||
elif t.kind == record:
|
||||
print(" {", end=' ')
|
||||
for f in t.ctorsOrFields:
|
||||
print(f"{f.name};", end=' ')
|
||||
@ -121,14 +154,18 @@ for t in adts:
|
||||
for f in t.ctorsOrFields:
|
||||
print(f"{f.newName};", end=' ')
|
||||
print("}, state)")
|
||||
else:
|
||||
print(f" v -> fold_{t.kind} v state (", end=' ')
|
||||
print(", ".join([f"continue.{t.name}_{f.name}" for f in t.ctorsOrFields]), end='')
|
||||
print(" )")
|
||||
print(" );")
|
||||
print(f" {t.name}_pre_state = (fun v state -> ignore v; state) ;")
|
||||
print(f" {t.name}_post_state = (fun v new_v state -> ignore (v, new_v); state) ;")
|
||||
for c in t.ctorsOrFields:
|
||||
print(f" {t.name}_{c.name} = (fun v state continue ->", end=' ')
|
||||
if c.isBuiltin:
|
||||
print("ignore continue; (v, state)", end=' ')
|
||||
print("ignore continue; (v, state)", end='')
|
||||
else:
|
||||
print(f"continue.{c.type_} v state", end=' ')
|
||||
print(f"continue.{c.type_} v state", end='')
|
||||
print(") ;")
|
||||
print("}")
|
||||
|
364
src/stages/adt_generator/generator.raku
Normal file
364
src/stages/adt_generator/generator.raku
Normal file
@ -0,0 +1,364 @@
|
||||
#!/usr/bin/env perl6
|
||||
use v6.c;
|
||||
use strict;
|
||||
use worries;
|
||||
|
||||
my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_");
|
||||
my $variant = "_ _variant";
|
||||
my $record = "_ _ record";
|
||||
sub poly { $^type_name }
|
||||
|
||||
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'"
|
||||
# }
|
||||
|
||||
|
||||
|
||||
# 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, $type) {
|
||||
my $isBuiltin = ! $l.cache.first({ $_<name> eq $type });
|
||||
{
|
||||
name => $cf ,
|
||||
newName => "$cf'" ,
|
||||
isBuiltin => $isBuiltin ,
|
||||
type => $type ,
|
||||
newType => $isBuiltin ?? $type !! "$type'"
|
||||
}
|
||||
}, @ctorsOrFields),
|
||||
}
|
||||
}, @$l.cache).list;
|
||||
|
||||
# say $adts.perl;
|
||||
|
||||
# say $adts.perl ;
|
||||
|
||||
say "(* This is an auto-generated file. Do not edit. *)";
|
||||
|
||||
say "";
|
||||
say "open $moduleName";
|
||||
say "open {$moduleName}_utils";
|
||||
say "module Adt_info = Generic.Adt_info";
|
||||
|
||||
say "";
|
||||
for $adts.kv -> $index, $t {
|
||||
my $typeOrAnd = $index == 0 ?? "type" !! "and";
|
||||
say "$typeOrAnd $t<newName> =";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " | $c<newName> of $c<newType>" }
|
||||
} elsif ($t<kind> eq $record) {
|
||||
say ' {';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " $f<newName> : $f<newType> ;"; }
|
||||
say ' }';
|
||||
} else {
|
||||
print " ";
|
||||
for $t<ctorsOrFields>.list -> $a
|
||||
{ print "$a<newType> "; }
|
||||
print "$t<kind>";
|
||||
say "";
|
||||
}
|
||||
}
|
||||
|
||||
say "";
|
||||
say "type 'state continue_fold_map =";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>_$c<name> : $c<type> -> 'state -> ($c<newType> * 'state) ;" } }
|
||||
say ' }';
|
||||
|
||||
say "";
|
||||
say "type 'state fold_map_config =";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ 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_instance_info ->*) 'state -> ('state continue_fold_map) -> ($c<newType> * 'state) ;";
|
||||
} }
|
||||
say ' }';
|
||||
|
||||
say "";
|
||||
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 "(* map from node names to their generic folds *)";
|
||||
say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t";
|
||||
say "";
|
||||
say "type 'state fold_config =";
|
||||
say ' {';
|
||||
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
|
||||
{ say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; }
|
||||
say ' }';
|
||||
say "(* info for adt $moduleName *)";
|
||||
print "let rec whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
|
||||
for $adts.list -> $t
|
||||
{ print "info_$t<name> ; "; }
|
||||
say "]";
|
||||
|
||||
# generic programming info about the nodes and fields
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ for $t<ctorsOrFields>.list -> $c
|
||||
{ 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 " is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
|
||||
say " type_ = \"$c<type>\";";
|
||||
say '}';
|
||||
say "";
|
||||
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> *)";
|
||||
say "and info_$t<name> : Adt_info.node = \{";
|
||||
my $kind = do given $t<kind> {
|
||||
when $record { "Record" }
|
||||
when $variant { "Variant" }
|
||||
default { "Poly \"$_\"" }
|
||||
};
|
||||
say " kind = $kind;";
|
||||
say " declaration_name = \"$t<name>\";";
|
||||
print " ctors_or_fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
|
||||
say "];";
|
||||
say '}';
|
||||
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 ' instance_kind = RecordInstance {';
|
||||
print " fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "continue_info_$t<name>_$c<name> visitor x.$c<name> ; "; }
|
||||
say " ];";
|
||||
say '};';
|
||||
}
|
||||
when $variant {
|
||||
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 = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
|
||||
say "];";
|
||||
say '};';
|
||||
}
|
||||
default {
|
||||
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 " poly_continue = (fun state -> visitor.$_ visitor x (";
|
||||
print $t<ctorsOrFields>
|
||||
.map(-> $c { "(fun state x -> (continue_info_$t<name>_$c<name> visitor x).cf_continue state)" })
|
||||
.join(", ");
|
||||
say ") state);";
|
||||
say '};';
|
||||
}
|
||||
};
|
||||
say '}';
|
||||
say ""; }
|
||||
|
||||
# make the "continue" object
|
||||
say "";
|
||||
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
|
||||
say "and mk_continue_fold_map : type qstate . qstate fold_map_config -> qstate continue_fold_map = fun visitor ->";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = fold_map_$t<name> visitor ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>_$c<name> = fold_map_$t<name>_$c<name> visitor ;"; } }
|
||||
say ' }';
|
||||
say "";
|
||||
|
||||
# fold_map functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "and fold_map_$t<name> : type qstate . qstate fold_map_config -> $t<name> -> qstate -> ($t<newName> * qstate) = fun visitor x state ->";
|
||||
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in";
|
||||
say " let state = visitor.$t<name>_pre_state x (*(fun () -> whole_adt_info, info_$t<name>)*) state in";
|
||||
say " let (new_x, state) = visitor.$t<name> x (*(fun () -> whole_adt_info, info_$t<name>)*) state continue_fold_map in";
|
||||
say " let state = visitor.$t<name>_post_state x new_x (*(fun () -> whole_adt_info, info_$t<name>)*) state in";
|
||||
say " (new_x, state)";
|
||||
say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "and fold_map_$t<name>_$c<name> : type qstate . qstate fold_map_config -> $c<type> -> qstate -> ($c<newType> * qstate) = fun visitor x state ->";
|
||||
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in";
|
||||
say " visitor.$t<name>_$c<name> x (*(fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>)*) state continue_fold_map";
|
||||
say ""; } }
|
||||
|
||||
|
||||
# fold functions
|
||||
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_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 " 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_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_instance_info*) visitor.$c<type> visitor x state in";
|
||||
} else {
|
||||
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";
|
||||
say ""; }
|
||||
}
|
||||
|
||||
say "let no_op : 'a fold_map_config = \{";
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = (fun v (*_info*) state continue ->";
|
||||
say " match v with";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " | $c<name> v -> let (v, state) = continue.$t<name>_$c<name> v state in ($c<newName> v, state)"; }
|
||||
} elsif ($t<kind> eq $record) {
|
||||
print ' { ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<name>; "; }
|
||||
say "} ->";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " let ($f<newName>, state) = continue.$t<name>_$f<name> $f<name> state in"; }
|
||||
print ' ({ ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<newName>; "; }
|
||||
say '}, state)';
|
||||
} else {
|
||||
print " v -> fold_map_$t<kind> v state ( ";
|
||||
print ( "continue.$t<name>_$_<name>" for $t<ctorsOrFields>.list ).join(", ");
|
||||
say " )";
|
||||
}
|
||||
say " );";
|
||||
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 (*_info*) state continue -> ";
|
||||
if ($c<isBuiltin>) {
|
||||
print "ignore continue; (v, state)";
|
||||
} else {
|
||||
print "continue.$c<type> v state";
|
||||
}
|
||||
say ") ;"; } }
|
||||
say '}';
|
59
src/stages/adt_generator/generic.ml
Normal file
59
src/stages/adt_generator/generic.ml
Normal file
@ -0,0 +1,59 @@
|
||||
module Adt_info = struct
|
||||
type kind =
|
||||
| Record
|
||||
| Variant
|
||||
| Poly of string
|
||||
|
||||
type 'state record_instance = {
|
||||
fields : 'state ctor_or_field_instance list;
|
||||
}
|
||||
|
||||
and 'state constructor_instance = {
|
||||
constructor : 'state ctor_or_field_instance ;
|
||||
variant : ctor_or_field list
|
||||
}
|
||||
|
||||
and 'state poly_instance = {
|
||||
poly : string;
|
||||
arguments : string list;
|
||||
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 ctor_or_field =
|
||||
{
|
||||
name : string;
|
||||
is_builtin : bool;
|
||||
type_ : string;
|
||||
}
|
||||
|
||||
and 'state ctor_or_field_instance =
|
||||
{
|
||||
cf : ctor_or_field;
|
||||
cf_continue : 'state -> 'state
|
||||
}
|
||||
|
||||
type node =
|
||||
{
|
||||
kind : kind;
|
||||
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_instance_info = {
|
||||
adt : adt ;
|
||||
node_instance : 'state instance ;
|
||||
}
|
||||
type 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
|
||||
end
|
@ -1,13 +1,13 @@
|
||||
open A
|
||||
open Amodule
|
||||
open Fold
|
||||
|
||||
(* TODO: how should we plug these into our test framework? *)
|
||||
|
||||
let () =
|
||||
let some_root : root = A { a1 = X (A { a1 = X (B 1) ; a2 = W () ; }) ; a2 = Z (W ()) ; } in
|
||||
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
|
||||
({
|
||||
@ -16,33 +16,68 @@ let () =
|
||||
}, state'' + 1)
|
||||
} in
|
||||
let state = 0 in
|
||||
let (_, state) = fold_root op some_root state in
|
||||
let (_, state) = fold_map_root op some_root state in
|
||||
if state != 2 then
|
||||
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
|
||||
else
|
||||
()
|
||||
|
||||
let () =
|
||||
let some_root : root = A { a1 = X (A { a1 = X (B 1) ; a2 = W () ; }) ; a2 = Z (W ()) ; } in
|
||||
let op = { no_op with a_pre_state = fun _the_a state -> state + 1 } in
|
||||
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 (*_info*) state -> state + 1 } in
|
||||
let state = 0 in
|
||||
let (_, state) = fold_root op some_root state in
|
||||
let (_, state) = fold_map_root op some_root state in
|
||||
if state != 2 then
|
||||
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
|
||||
else
|
||||
()
|
||||
|
||||
let () =
|
||||
let some_root : root = A { a1 = X (A { a1 = X (B 1) ; a2 = W () ; }) ; a2 = Z (W ()) ; } in
|
||||
let op = { no_op with a_post_state = fun _the_a _new_a state -> state + 1 } in
|
||||
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 (*_info*) state -> state + 1 } in
|
||||
let state = 0 in
|
||||
let (_, state) = fold_root op some_root state in
|
||||
let (_, state) = fold_map_root op some_root state in
|
||||
if state != 2 then
|
||||
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
|
||||
else
|
||||
()
|
||||
|
||||
|
||||
(* Test that the same fold_config can be ascibed with different 'a type arguments *)
|
||||
let _noi : int fold_config = no_op (* (fun _ -> ()) *)
|
||||
let _nob : bool fold_config = no_op (* (fun _ -> ()) *)
|
||||
(* Test that the same fold_map_config can be ascibed with different 'a type arguments *)
|
||||
let _noi : int fold_map_config = no_op (* (fun _ -> ()) *)
|
||||
let _nob : bool fold_map_config = no_op (* (fun _ -> ()) *)
|
||||
|
||||
let () =
|
||||
let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in
|
||||
let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in
|
||||
let nostate = false, "" in
|
||||
let op = {
|
||||
generic = (fun info state ->
|
||||
assert_nostate state;
|
||||
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)
|
||||
| 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 , "()") ;
|
||||
int = (fun _visitor i state -> assert_nostate state; false , string_of_int i) ;
|
||||
list = (fun _visitor lst continue state ->
|
||||
assert_nostate state;
|
||||
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
|
||||
(* generic_ctor_or_field = (fun _info state ->
|
||||
* match _info () with
|
||||
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
|
||||
* ); *)
|
||||
} in
|
||||
let (_ , state) = fold_root op some_root nostate in
|
||||
let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
|
||||
if String.equal state expected; then
|
||||
()
|
||||
else
|
||||
failwith (Printf.sprintf "Test failed: expected\n %s\n but got\n %s" expected state)
|
||||
|
@ -21,7 +21,7 @@ FROM node:12-buster
|
||||
|
||||
WORKDIR /app
|
||||
|
||||
RUN apt-get update && apt-get -y install libev-dev perl pkg-config libgmp-dev libhidapi-dev m4 libcap-dev bubblewrap rsync
|
||||
RUN apt-get update && apt-get -y install perl6 libev-dev perl pkg-config libgmp-dev libhidapi-dev m4 libcap-dev bubblewrap rsync
|
||||
|
||||
COPY ligo_deb10.deb /tmp/ligo_deb10.deb
|
||||
RUN dpkg -i /tmp/ligo_deb10.deb && rm /tmp/ligo_deb10.deb
|
||||
|
40
vendors/UnionFind/UnionFind.install
vendored
40
vendors/UnionFind/UnionFind.install
vendored
@ -1,40 +0,0 @@
|
||||
lib: [
|
||||
"_build/install/default/lib/UnionFind/META"
|
||||
"_build/install/default/lib/UnionFind/Partition.mli"
|
||||
"_build/install/default/lib/UnionFind/Partition0.ml"
|
||||
"_build/install/default/lib/UnionFind/Partition1.ml"
|
||||
"_build/install/default/lib/UnionFind/Partition2.ml"
|
||||
"_build/install/default/lib/UnionFind/Partition3.ml"
|
||||
"_build/install/default/lib/UnionFind/UnionFind.a"
|
||||
"_build/install/default/lib/UnionFind/UnionFind.cma"
|
||||
"_build/install/default/lib/UnionFind/UnionFind.cmxa"
|
||||
"_build/install/default/lib/UnionFind/UnionFind.cmxs"
|
||||
"_build/install/default/lib/UnionFind/dune-package"
|
||||
"_build/install/default/lib/UnionFind/opam"
|
||||
"_build/install/default/lib/UnionFind/unionFind.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind.cmt"
|
||||
"_build/install/default/lib/UnionFind/unionFind.cmx"
|
||||
"_build/install/default/lib/UnionFind/unionFind.ml"
|
||||
"_build/install/default/lib/UnionFind/unionFind__.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind__.cmt"
|
||||
"_build/install/default/lib/UnionFind/unionFind__.cmx"
|
||||
"_build/install/default/lib/UnionFind/unionFind__.ml"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition.cmti"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition0.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition0.cmt"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition0.cmx"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition1.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition1.cmt"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition1.cmx"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition2.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition2.cmt"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition2.cmx"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition3.cmi"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition3.cmt"
|
||||
"_build/install/default/lib/UnionFind/unionFind__Partition3.cmx"
|
||||
]
|
||||
doc: [
|
||||
"_build/install/default/doc/UnionFind/LICENSE"
|
||||
"_build/install/default/doc/UnionFind/README.md"
|
||||
]
|
Loading…
Reference in New Issue
Block a user