diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 0df2e2e4d..a275dda33 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -880,7 +880,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - let%bind (ex' , state') = type_expression e state matchee in let%bind (m' , state'') = type_match e state' ex'.type_expression cases ae ae.location in let tvs = - let aux (cur : O.matching_content) = + let aux (cur : O.matching_expr) = match cur with | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ] diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 5871fd13d..0b8266a11 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -284,7 +284,7 @@ and expression_content ppf (ec: expression_content) = and assoc_expression ppf : map_kv -> unit = fun {k ; v} -> fprintf ppf "%a -> %a" expression k expression v -and single_record_patch ppf ((p, expr) : label * expr) = +and single_record_patch ppf ((p, expr) : label * expression) = fprintf ppf "%a <- %a" label p expression expr @@ -298,7 +298,7 @@ and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_c fun f ppf {constructor=c; pattern; body} -> fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body -and matching : (formatter -> expression -> unit) -> _ -> matching_content -> unit = fun f ppf m -> match m with +and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with | Match_tuple {vars; body; tvs=_} -> fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body | Match_variant {cases ; tv=_} -> diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index 6b865e119..a9eaaf2c9 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -126,7 +126,7 @@ val e_chain_id : string -> expression_content val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression_content val e_lambda : lambda -> expression_content val e_pair : expression -> expression -> expression_content -val e_application : expression -> expr -> expression_content +val e_application : expression -> expression -> expression_content val e_variable : expression_variable -> expression_content val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content diff --git a/src/stages/4-ast_typed/dune b/src/stages/4-ast_typed/dune index c6451404c..7a16fdd2a 100644 --- a/src/stages/4-ast_typed/dune +++ b/src/stages/4-ast_typed/dune @@ -1,9 +1,9 @@ -; (rule -; (target generated_fold.ml) -; (deps ../adt_generator/generator.raku types.ml) -; (action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml))) -; ; (mode (promote (until-clean))) -; ) +(rule + (target generated_fold.ml) + (deps ../adt_generator/generator.raku types.ml) + (action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml))) +; (mode (promote (until-clean))) +) (library (name ast_typed) @@ -13,6 +13,7 @@ tezos-utils ast_core ; Is that a good idea? stage_common + adt_generator ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index e4941a4ba..152c462dc 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -232,7 +232,7 @@ module Free_variables = struct and matching_variant_case : (bindings -> expression -> bindings) -> bindings -> matching_content_case -> bindings = fun f b { constructor=_ ; pattern ; body } -> f (union (singleton pattern) b) body - and matching : (bindings -> expression -> bindings) -> bindings -> matching_content -> bindings = fun f b m -> + and matching : (bindings -> expression -> bindings) -> bindings -> matching_expr -> bindings = fun f b m -> match m with | Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) | Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body) diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 8ff39309a..6b643d742 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -89,7 +89,7 @@ module Captured_variables = struct and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } -> f (union (singleton pattern) b) body - and matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result = fun f b m -> + and matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result = fun f b m -> match m with | Match_bool { match_true = t ; match_false = fa } -> let%bind t' = f b t in diff --git a/src/stages/4-ast_typed/misc_smart.mli b/src/stages/4-ast_typed/misc_smart.mli index 5b043401a..52fcb29c4 100644 --- a/src/stages/4-ast_typed/misc_smart.mli +++ b/src/stages/4-ast_typed/misc_smart.mli @@ -6,7 +6,7 @@ val program_to_main : program -> string -> lambda result module Captured_variables : sig type bindings = expression_variable list - val matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result + val matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result val matching_expression : bindings -> matching_expr -> bindings result diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 06ba61eba..28ffb6644 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -19,9 +19,12 @@ type type_constant = | TC_timestamp | TC_void -type type_content = - | T_sum of type_expression constructor_map - | T_record of type_expression label_map +type te_cmap = type_expression constructor_map +and te_lmap = type_expression label_map + +and type_content = + | T_sum of te_cmap + | T_record of te_lmap | T_arrow of arrow | T_variable of type_variable | T_constant of type_constant @@ -29,7 +32,7 @@ type type_content = and arrow = { type1: type_expression; - type2: type_expression + type2: type_expression; } and type_map_args = { @@ -56,7 +59,7 @@ and type_operator = and type_expression = { type_content: type_content; - type_meta: type_meta + type_meta: type_meta; } type literal = @@ -74,7 +77,7 @@ type literal = | Literal_key_hash of string | Literal_chain_id of string | Literal_void - | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation + | Literal_operation of packed_internal_operation type matching_content_bool = { match_true : expression ; @@ -104,10 +107,13 @@ and matching_content_option = { match_some : matching_content_some ; } +and expression_variable_list = expression_variable list +and type_expression_list = type_expression list + and matching_content_tuple = { - vars : expression_variable list ; + vars : expression_variable_list ; body : expression ; - tvs : type_expression list ; + tvs : type_expression_list ; } and matching_content_case = { @@ -115,12 +121,15 @@ and matching_content_case = { pattern : expression_variable ; body : expression ; } + +and matching_content_case_list = matching_content_case list + and matching_content_variant = { - cases: matching_content_case list; + cases: matching_content_case_list; tv: type_expression; } -and matching_content = +and matching_expr = | Match_bool of matching_content_bool | Match_list of matching_content_list | Match_option of matching_content_option @@ -242,14 +251,14 @@ and constant' = | C_SET_DELEGATE | C_CREATE_CONTRACT -and program = declaration Location.wrap list +and declaration_loc = declaration location_wrap -and inline = bool +and program = declaration_loc list and declaration_constant = { binder : expression_variable ; expr : expression ; - inline : inline ; + inline : bool ; post_env : full_environment ; } @@ -268,7 +277,7 @@ and declaration = and expression = { expression_content: expression_content ; - location: Location.t ; + location: location ; type_expression: type_expression ; environment: full_environment ; } @@ -283,6 +292,9 @@ and look_up = { ind : expression; } +and expression_label_map = expression label_map +and map_kv_list = map_kv list +and expression_list = expression list and expression_content = (* Base *) @@ -297,13 +309,14 @@ and expression_content = | E_constructor of constructor (* For user defined constructors *) | E_matching of matching (* Record *) - | E_record of expression label_map + | E_record of expression_label_map | E_record_accessor of record_accessor | E_record_update of record_update -and constant = - { cons_name: constant' - ; arguments: expression list } +and constant = { + cons_name: constant' ; + arguments: expression_list ; + } and application = { lamb: expression ; @@ -321,7 +334,7 @@ and let_in = { let_binder: expression_variable ; rhs: expression ; let_result: expression ; - inline : inline ; + inline : bool ; } and recursive = { @@ -346,10 +359,9 @@ and record_update = { update: expression ; } -and matching_expr = matching_content -and matching = - { matchee: expression - ; cases: matching_expr +and matching = { + matchee: expression ; + cases: matching_expr ; } and ascription = { @@ -394,13 +406,10 @@ and small_environment = { type_environment: type_environment ; } -and full_environment = small_environment List.Ne.t - -and expr = expression - -and texpr = type_expression +and full_environment = small_environment list_ne and named_type_content = { type_name : type_variable; type_value : type_expression; } + diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 8ca8f4a47..d7d9aa61c 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -21,3 +21,22 @@ module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = type 'a label_map = 'a LMap.t type 'a constructor_map = 'a CMap.t type type_meta = S.type_expression option + +type 'a location_wrap = 'a Location.wrap +type 'a list_ne = 'a List.Ne.t +type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation +type location = Location.t +type inline = bool + +let fold_map__constructor_map : 'a . 'a constructor_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a constructor_map * 'state = fun _ _ _ -> failwith "TODO fold_map__constructor_map" + +let fold_map__label_map : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = fun _ _ _ -> failwith "TODO fold_map__label_map" + +let fold_map__list : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = fun l state f -> + let aux (state, l) element = let (new_element, state) = f element state in (state, new_element::l) in + let (state, l) = List.fold_left aux (state, []) l in + (l, state) + +let fold_map__location_wrap : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap" + +let fold_map__list_ne : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap" diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 555e98f22..6430e0773 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -16,22 +16,26 @@ my $statements = $l.grep($statement_re); $l = $l.grep(none $statement_re); $statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, '')); $l = $l.cache.map(*.subst: /^type\s+/, "\nand "); -$l = $l.join("\n").subst(/\n+/, "\n").split(/\nand\s+/).grep(/./); +# TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose. +$l = $l.join("\n").subst(/\n+/, "\n", :g); # join lines and remove consecutive newlines +$l = $l.subst(/\s*\(\* ( <-[\*]> | \*+<-[\*\)]> )* \*\)/, '', :g); # discard comments (incl. multi-line comments) +$l = $l.split(/\nand\s+/).grep(/./); # split lines again and preserve nonempty lines $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]") } + 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; } + 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]" } + when /^\|\s*((\w|\')+)\s*of\s+((\w|\')+)$/ { "$/[0]", "$/[1]" } + when /^\|\s*((\w|\')+)$/ { "$/[0]", "" } + when /^((\w|\')+)\s*\:\s*((\w|\')+)\s*\;$/ { "$/[0]", "$/[1]" } default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" } } }; @@ -114,16 +118,16 @@ $l = $l.map: { my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) { { "name" => $name , - "newName" => "$name'" , + "newName" => "{$name}__'" , "kind" => $kind , "ctorsOrFields" => @(map -> ($cf, $type) { - my $isBuiltin = ! $l.cache.first({ $_ eq $type }); + my $isBuiltin = (! $type) || (! $l.cache.first({ $_ eq $type })); { name => $cf , - newName => "$cf'" , + newName => "{$cf}__'" , isBuiltin => $isBuiltin , type => $type , - newType => $isBuiltin ?? $type !! "$type'" + newType => $isBuiltin ?? "$type" !! "{$type}__'" } }, @ctorsOrFields), } @@ -147,8 +151,12 @@ for $adts.kv -> $index, $t { my $typeOrAnd = $index == 0 ?? "type" !! "and"; say "$typeOrAnd $t ="; if ($t eq $variant) { - for $t.list -> $c - { say " | $c of $c" } + for $t.list -> $c { + given $c { + when '' { say " | $c" } + default { say " | $c of $c" } + } + } } elsif ($t eq $record) { say ' {'; for $t.list -> $f @@ -166,10 +174,11 @@ for $adts.kv -> $index, $t { say ""; say "type 'state continue_fold_map ="; say ' {'; -for $adts.list -> $t -{ say " $t : $t -> 'state -> ($t * 'state) ;"; - for $t.list -> $c - { say " $t_$c : $c -> 'state -> ($c * 'state) ;" } } +for $adts.list -> $t { + say " $t : $t -> 'state -> ($t * 'state) ;"; + for $t.list -> $c + { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } +} say ' }'; say ""; @@ -177,10 +186,10 @@ say "type 'state fold_map_config ="; say ' {'; for $adts.list -> $t { say " $t : $t -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t * 'state) ;"; - say " $t_pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; - say " $t_post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; + say " $t__pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; + say " $t__post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; for $t.list -> $c - { say " $t_$c : $c -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ($c * 'state) ;"; + { say " $t__$c : {$c || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c || 'unit'} * 'state) ;"; } } say ' }'; @@ -198,7 +207,7 @@ say ""; say "type 'state fold_config ="; say ' {'; say " generic : 'state Adt_info.node_instance_info -> 'state -> 'state;"; -for $adts.map({ $_ })[*;*].grep({$_}).map({$_}).unique -> $builtin +for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin { say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; } for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $builtin { say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; } @@ -206,7 +215,7 @@ say ' }'; say "(* info for adt $moduleName *)"; print "let rec whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; for $adts.list -> $t -{ print "info_$t ; "; } +{ print "info__$t ; "; } say "]"; # generic programming info about the nodes and fields @@ -214,19 +223,19 @@ say ""; for $adts.list -> $t { for $t.list -> $c { say "(* info for field or ctor $t.$c *)"; - say "and info_$t_$c : Adt_info.ctor_or_field = \{"; + say "and info__$t__$c : Adt_info.ctor_or_field = \{"; say " name = \"$c\";"; say " is_builtin = {$c ?? 'true' !! 'false'};"; say " type_ = \"$c\";"; say '}'; say ""; - say "and continue_info_$t_$c : type qstate . qstate fold_config -> $c -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{"; - say " cf = info_$t_$c;"; - say " cf_continue = fun state -> fold_$t_$c visitor x state;"; + say "and continue_info__$t__$c : type qstate . qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{"; + say " cf = info__$t__$c;"; + say " cf_continue = fun state -> fold__$t__$c visitor x state;"; say '}'; say ""; } say "(* info for node $t *)"; - say "and info_$t : Adt_info.node = \{"; + say "and info__$t : Adt_info.node = \{"; my $kind = do given $t { when $record { "Record" } when $variant { "Variant" } @@ -235,29 +244,29 @@ for $adts.list -> $t say " kind = $kind;"; say " declaration_name = \"$t\";"; print " ctors_or_fields = [ "; - for $t.list -> $c { print "info_$t_$c ; "; } + for $t.list -> $c { print "info__$t__$c ; "; } say "];"; say '}'; say ""; # TODO: factor out some of the common bits here. - say "and continue_info_$t : type qstate . qstate fold_config -> $t -> qstate Adt_info.instance = fun visitor x ->"; + say "and continue_info__$t : type qstate . qstate fold_config -> $t -> qstate Adt_info.instance = fun visitor x ->"; say '{'; say " instance_declaration_name = \"$t\";"; do given $t { when $record { say ' instance_kind = RecordInstance {'; print " fields = [ "; - for $t.list -> $c { print "continue_info_$t_$c visitor x.$c ; "; } + for $t.list -> $c { print "continue_info__$t__$c visitor x.$c ; "; } say " ];"; say '};'; } when $variant { say ' instance_kind = VariantInstance {'; say " constructor = (match x with"; - for $t.list -> $c { say " | $c v -> continue_info_$t_$c visitor v"; } + for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c visitor { $c ?? 'v' !! '()' }"; } say " );"; print " variant = [ "; - for $t.list -> $c { print "info_$t_$c ; "; } + for $t.list -> $c { print "info__$t__$c ; "; } say "];"; say '};'; } @@ -271,7 +280,7 @@ for $adts.list -> $t say "];"; print " poly_continue = (fun state -> visitor.$_ visitor x ("; print $t - .map(-> $c { "(fun state x -> (continue_info_$t_$c visitor x).cf_continue state)" }) + .map(-> $c { "(fun state x -> (continue_info__$t__$c visitor x).cf_continue state)" }) .join(", "); say ") state);"; say '};'; @@ -286,51 +295,53 @@ say '(* Curries the "visitor" argument to the folds (non-customizable traversal 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 = fold_map_$t visitor ;"; +{ say " $t = fold_map__$t visitor ;"; for $t.list -> $c - { say " $t_$c = fold_map_$t_$c visitor ;"; } } + { say " $t__$c = fold_map__$t__$c visitor ;"; } } say ' }'; say ""; # fold_map functions say ""; for $adts.list -> $t -{ say "and fold_map_$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state ->"; +{ say "and fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * 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_pre_state x (*(fun () -> whole_adt_info, info_$t)*) state in"; - say " let (new_x, state) = visitor.$t x (*(fun () -> whole_adt_info, info_$t)*) state continue_fold_map in"; - say " let state = visitor.$t_post_state x new_x (*(fun () -> whole_adt_info, info_$t)*) state in"; + say " let state = visitor.$t__pre_state x (*(fun () -> whole_adt_info, info__$t)*) state in"; + say " let (new_x, state) = visitor.$t x (*(fun () -> whole_adt_info, info__$t)*) state continue_fold_map in"; + say " let state = visitor.$t__post_state x new_x (*(fun () -> whole_adt_info, info__$t)*) state in"; say " (new_x, state)"; say ""; for $t.list -> $c - { say "and fold_map_$t_$c : type qstate . qstate fold_map_config -> $c -> qstate -> ($c * qstate) = fun visitor x state ->"; + { say "and fold_map__$t__$c : type qstate . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state ->"; say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in"; - say " visitor.$t_$c x (*(fun () -> whole_adt_info, info_$t, info_$t_$c)*) state continue_fold_map"; + say " visitor.$t__$c x (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) state continue_fold_map"; say ""; } } # fold functions say ""; for $adts.list -> $t -{ say "and fold_$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state ->"; +{ say "and fold__$t : type qstate . qstate fold_config -> $t -> 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 visitor x"; + say " node_instance = continue_info__$t visitor x"; say ' } in'; - # say " let (new_x, state) = visitor.$t x (fun () -> whole_adt_info, info_$t) state continue_fold in"; + # say " let (new_x, state) = visitor.$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; say " visitor.generic node_instance_info state"; say ""; for $t.list -> $c - { say "and fold_$t_$c : type qstate . qstate fold_config -> $c -> 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, continue_info_$t_$c visitor x in"; - if ($c) { + { say "and fold__$t__$c : type qstate . qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun { $c ?? 'visitor x' !! '_visitor ()' } state ->"; + # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; + if ($c eq '') { + # nothing to do, this constructor has no arguments. + } elsif ($c) { say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) visitor.$c visitor x state in"; } else { - say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold_$c visitor x state in"; + say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold__$c visitor x state in"; } say " state"; - # say " visitor.$t_$c x (fun () -> whole_adt_info, info_$t, info_$t_$c) state continue_fold"; + # say " visitor.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } } @@ -340,28 +351,30 @@ for $adts.list -> $t say " match v with"; if ($t eq $variant) { for $t.list -> $c - { say " | $c v -> let (v, state) = continue.$t_$c v state in ($c v, state)"; } + { given $c { + when '' { say " | $c -> let ((), state) = continue.$t__$c () state in ($c, state)"; } + default { say " | $c v -> let (v, state) = continue.$t__$c v state in ($c v, state)"; } } } } elsif ($t eq $record) { print ' { '; for $t.list -> $f { print "$f; "; } say "} ->"; for $t.list -> $f - { say " let ($f, state) = continue.$t_$f $f state in"; } + { say " let ($f, state) = continue.$t__$f $f state in"; } print ' ({ '; for $t.list -> $f { print "$f; "; } say '}, state)'; } else { - print " v -> fold_map_$t v state ( "; - print ( "continue.$t_$_" for $t.list ).join(", "); + print " v -> fold_map__$t v state ( "; + print ( "continue.$t__$_" for $t.list ).join(", "); say " )"; } say " );"; - 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) ;"; + 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 (*_info*) state continue -> "; + { print " $t__$c = (fun v (*_info*) state continue -> "; if ($c) { print "ignore continue; (v, state)"; } else { diff --git a/src/test/adt_generator/amodule_utils.ml b/src/test/adt_generator/amodule_utils.ml index 0e3855bb8..b0a666dd6 100644 --- a/src/test/adt_generator/amodule_utils.ml +++ b/src/test/adt_generator/amodule_utils.ml @@ -1,10 +1,10 @@ -let fold_map_list v state continue = +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 = +let fold_map__option v state continue = match v with Some x -> continue x state | None -> None diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index c62c38e0f..8774e1200 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -8,15 +8,12 @@ let () = let op = { no_op with 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 - ({ - a1' = a1' ; - a2' = a2' ; - }, state'' + 1) + let (a1__' , state') = continue_fold.ta1 the_a.a1 state in + let (a2__' , state'') = continue_fold.ta2 the_a.a2 state' in + ({ a1__' ; a2__' }, state'' + 1) } in let state = 0 in - let (_, state) = fold_map_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 @@ -24,9 +21,9 @@ 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 (*_info*) 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_map_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 @@ -34,9 +31,9 @@ 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 (*_info*) 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_map_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 @@ -75,7 +72,7 @@ let () = * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" * ); *) } in - let (_ , state) = fold_root op some_root nostate 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 ()