balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

auto-generated folds: have a distinct input and output type for the state

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-05-22 19:27:10 +01:00
parent ee5e484bf4
commit 851132528d
5 changed files with 124 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
src/stages/4-ast_typed/PP_generic.ml
View File

@ -4,14 +4,16 @@ open Format
open PP_helpers
module M = struct
type no_state = NoState
let needs_parens = {
generic = (fun state info ->
generic = (fun NoState info ->
match info.node_instance.instance_kind with
| RecordInstance _ -> false
| VariantInstance _ -> true
| PolyInstance { poly =_; arguments=_; poly_continue } ->
(poly_continue state)
(poly_continue NoState)
);
generic_empty_ctor = (fun _ -> false) ;
type_variable = (fun _ _ _ -> true) ;
bool = (fun _ _ _ -> false) ;
int = (fun _ _ _ -> false) ;
@ -37,83 +39,81 @@ module M = struct
typeVariableMap = (fun _ _ _ _ -> false) ;
}
let op ppf = {
generic = (fun () info ->
let op ppf : (no_state, unit) fold_config = {
generic = (fun NoState info ->
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) =
fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in
let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in
fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
| VariantInstance { constructor ; _ } ->
if constructor.cf_new_fold needs_parens false
then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) ()
if constructor.cf_new_fold needs_parens NoState
then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState
else let spc = if String.equal constructor.cf.type_ "" then "" else " " in
fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) ()
fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue ())
(poly_continue NoState)
);
int = (fun _visitor () i -> fprintf ppf "%i" i );
type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ;
z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ;
string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ;
ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ;
bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ;
unit = (fun _visitor () () -> fprintf ppf "()") ;
packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ;
expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ;
constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ;
location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ;
label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ;
ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
constructor_map = (fun _visitor continue () cmap ->
generic_empty_ctor = (fun NoState -> ()) ;
int = (fun _visitor NoState i -> fprintf ppf "%i" i );
type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ;
z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ;
string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ;
ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ;
bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ;
unit = (fun _visitor NoState () -> fprintf ppf "()") ;
packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ;
expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ;
constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ;
label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ;
ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
constructor_map = (fun _visitor continue NoState cmap ->
let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
let aux ppf (Constructor k, v) =
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
fprintf ppf "CMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
label_map = (fun _visitor continue () lmap ->
label_map = (fun _visitor continue NoState lmap ->
let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
let aux ppf (Label k, v) =
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
fprintf ppf "LMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
list = (fun _visitor continue () lst ->
list = (fun _visitor continue NoState lst ->
let aux ppf elt =
fprintf ppf "%a" (fun _ppf -> continue ()) elt in
fprintf ppf "%a" (fun _ppf -> continue NoState) elt in
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
location_wrap = (fun _visitor continue () lwrap ->
location_wrap = (fun _visitor continue NoState lwrap ->
let ({ wrap_content; location } : _ Location.wrap) = lwrap in
fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location);
(* list_ne = (fun _visitor continue () (first, lst) ->
let aux ppf elt =
fprintf ppf "%a" (fun _ppf -> continue ()) elt in
fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *)
option = (fun _visitor continue () o ->
fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location);
option = (fun _visitor continue NoState o ->
match o with
| None -> fprintf ppf "None"
| Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ;
poly_unionfind = (fun _visitor continue () p ->
| Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ;
poly_unionfind = (fun _visitor continue NoState p ->
let lst = (UnionFind.Poly2.partitions p) in
let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]"
(fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p)
(list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in
(fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p)
(list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in
let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
fprintf ppf "UnionFind [@,@[<hv 2> %a @]@,]" aux2 lst);
poly_set = (fun _visitor continue () set ->
poly_set = (fun _visitor continue NoState set ->
let lst = (RedBlackTrees.PolySet.elements set) in
fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst);
typeVariableMap = (fun _visitor continue () tvmap ->
fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst);
typeVariableMap = (fun _visitor continue NoState tvmap ->
let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
let aux ppf (k, v) =
fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in
fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in
fprintf ppf "typeVariableMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
}
let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
fold (op ppf) () v
let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
fold (op ppf) NoState v
end
include Fold.Folds(struct
type state = unit ;;
type in_state = M.no_state ;;
type out_state = unit ;;
type 'a t = formatter -> 'a -> unit ;;
let f = M.print ;;
end)

37
src/stages/4-ast_typed/compare_generic.ml
View File

@ -5,7 +5,7 @@ module M = struct
let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *)
type 'a lz = unit -> 'a (* Lazy values *)
type t =
| NoState
| EmptyCtor
| Record of string * (string * t lz) list
| VariantConstructor of string * string * t lz
| Bool of inline
@ -30,12 +30,14 @@ module M = struct
| Set of t lz list
| TypeVariableMap of (type_variable * t lz) list
type no_state = NoState
(* TODO: make these functions return a lazy stucture *)
let op : t fold_config = {
generic = (fun _state info ->
let op : (no_state, t) fold_config = {
generic = (fun NoState info ->
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
let aux (fld : 'x Adt_info.ctor_or_field_instance) =
let aux (fld : ('xi, 'xo) Adt_info.ctor_or_field_instance) =
( fld.cf.name , fun () -> fld.cf_continue NoState ) in
Record ("name_of_the_record", List.map aux fields)
| VariantInstance { constructor ; _ } ->
@ -43,6 +45,7 @@ module M = struct
| PolyInstance { poly=_; arguments=_; poly_continue } ->
poly_continue NoState
);
generic_empty_ctor = (fun NoState -> EmptyCtor) ;
int = (fun _visitor _state i -> Int i );
type_variable = (fun _visitor _state type_variable -> Var type_variable) ;
bool = (fun _visitor _state b -> Bool b) ;
@ -72,7 +75,7 @@ module M = struct
(Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location}));
option = (fun _visitor continue _state o ->
match o with
| None -> VariantConstructor ("built-in:option", "None", fun () -> NoState)
| None -> VariantConstructor ("built-in:option", "None", fun () -> EmptyCtor)
| Some v -> VariantConstructor ("built-in:option", "Some", fun () -> continue NoState v));
poly_unionfind = (fun _visitor continue _state p ->
(* UnionFind.Poly2.partitions returns the partitions in a
@ -89,13 +92,17 @@ module M = struct
TypeVariableMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst));
}
let serialize : (t fold_config -> t -> 'a -> t) -> 'a -> t = fun fold v ->
let serialize : ((no_state, t) fold_config -> no_state -> 'a -> t) -> 'a -> t = fun fold v ->
fold op NoState v
(* What follows should be roughly the same for all ASTs, so it
should be easy to share a single copy of that and of the t type
definition above. *)
(* Generate a unique tag for each case handled below. We can then
compare data by their tag and contents. *)
let tag = function
| NoState -> 0
| EmptyCtor -> 0
| Record _ -> 1
| VariantConstructor _ -> 2
| Bool _ -> 3
@ -129,7 +136,7 @@ module M = struct
and compare_lz_t a b = compare_t (a ()) (b ())
and compare_t (a : t) (b : t) =
match (a, b) with
| (NoState, NoState) -> failwith "Should not happen (unless for ctors with no args?)"
| (EmptyCtor, EmptyCtor) -> failwith "Should not happen (unless for ctors with no args?)"
| (Record (a, fa), Record (b, fb)) -> cmp2 String.compare a b (List.compare ~compare:compare_field) fa fb
| (VariantConstructor (va, ca, xa), VariantConstructor (vb, cb, xb)) ->
cmp3
@ -158,21 +165,22 @@ module M = struct
| (Set a, Set b) -> List.compare ~compare:compare_lz_t a b
| (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry a b
| ((NoState | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a),
((NoState | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) ->
| ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a),
((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) ->
Int.compare (tag a) (tag b)
let mk_compare : (t fold_config -> t -> 'a -> t) -> 'a -> 'a -> int = fun fold a b ->
let mk_compare : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a -> 'a -> int = fun fold a b ->
compare_t (serialize fold a) (serialize fold b)
let mk_comparable : (t fold_config -> t -> 'a -> t) -> 'a extra_info__comparable = fun fold ->
let mk_comparable : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a extra_info__comparable = fun fold ->
{ compare = mk_compare fold }
end
(* Generate a comparison function for each type, named like the type itself. *)
include Folds(struct
type state = M.t ;;
type in_state = M.no_state ;;
type out_state = M.t ;;
type 'a t = 'a -> 'a -> int ;;
let f = M.mk_compare ;;
end)
@ -180,7 +188,8 @@ end)
module Comparable = struct
(* Generate a comparator typeclass-like object for each type, named like the type itself. *)
include Folds(struct
type state = M.t ;;
type in_state = M.no_state ;;
type out_state = M.t ;;
type 'a t = 'a extra_info__comparable ;;
let f = M.mk_comparable ;;
end)

41
src/stages/adt_generator/generator.raku
View File

@ -96,29 +96,30 @@ $*OUT = open $folder_filename, :w;
say "";
say " include Adt_generator.Generic.BlahBluh";
say " type ('state , 'adt_info_node_instance_info) _fold_config = \{";
say " generic : 'state -> 'adt_info_node_instance_info -> 'state;";
say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
say " generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;";
say " generic_empty_ctor : 'in_state -> 'out_state;";
# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
{ say " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; }
{ say " $builtin : ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> 'in_state -> $builtin -> 'out_state;"; }
# look for built-in polymorphic types
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say " $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
{ say " $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_state;"; }
say ' };;';
say "";
say " module Adt_info = Adt_generator.Generic.Adt_info (struct";
say " type nonrec ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;";
say " type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config;;";
say " end);;";
say " include Adt_info;;";
say " type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;";
say " type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_state) Adt_info.node_instance_info) _fold_config;;";
say "";
say ' type the_folds = {';
for $adts.list -> $t
{ say " fold__$t<name> : 'state . the_folds -> 'state fold_config -> 'state -> $t<name> -> 'state;";
{ say " fold__$t<name> : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> $t<name> -> 'out_state;";
for $t<ctorsOrFields>.list -> $c
{ say " fold__$t<name>__$c<name> : 'state . the_folds -> 'state fold_config -> 'state -> { $c<type> || 'unit' } -> 'state;"; } }
{ say " fold__$t<name>__$c<name> : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> { $c<type> || 'unit' } -> 'out_state;"; } }
say ' };;';
# generic programming info about the nodes and fields
@ -132,7 +133,7 @@ $*OUT = open $folder_filename, :w;
say " type_ = \"$c<type>\";";
say ' };;';
# say "";
say " let continue_info__$t<name>__$c<name> : type qstate . the_folds -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{";
say " let continue_info__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c<type> || 'unit'} -> (in_qstate, out_qstate) Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{";
say " cf = info__$t<name>__$c<name>;";
say " cf_continue = (fun state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
say " cf_new_fold = (fun visitor state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
@ -154,7 +155,7 @@ $*OUT = open $folder_filename, :w;
say ' };;';
# say "";
# TODO: factor out some of the common bits here.
say " let continue_info__$t<name> : type qstate . the_folds -> qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun the_folds visitor x ->";
say " let continue_info__$t<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> $t<name> -> (in_qstate , out_qstate) Adt_info.instance = fun the_folds visitor x ->";
say ' {';
say " instance_declaration_name = \"$t<name>\";";
do given $t<kind> {
@ -208,9 +209,9 @@ $*OUT = open $folder_filename, :w;
# fold functions
say "";
for $adts.list -> $t
{ say " let fold__$t<name> : type qstate . the_folds -> qstate fold_config -> qstate -> $t<name> -> qstate = fun the_folds visitor state x ->";
{ say " let fold__$t<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $t<name> -> out_qstate = fun the_folds visitor state x ->";
# TODO: add a non-generic continue_fold.
say ' let node_instance_info : qstate Adt_info.node_instance_info = {';
say ' let node_instance_info : (in_qstate , out_qstate) Adt_info.node_instance_info = {';
say " adt = whole_adt_info () ;";
say " node_instance = continue_info__$t<name> the_folds visitor x";
say ' } in';
@ -218,11 +219,11 @@ $*OUT = open $folder_filename, :w;
say " visitor.generic state node_instance_info;;";
# say "";
for $t<ctorsOrFields>.list -> $c
{ say " let fold__$t<name>__$c<name> : type qstate . the_folds -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun the_folds { $c<type> ?? 'visitor' !! '_visitor' } state { $c<type> ?? 'x' !! '()' } ->";
# 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";
{ say " let fold__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> { $c<type> || 'unit' } -> out_qstate = fun the_folds visitor state { $c<type> ?? 'x' !! '()' } ->";
# say " let ctor_or_field_instance_info : (in_qstate , out_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<type> eq '') {
# nothing to do, this constructor has no arguments.
say " ignore the_folds; state;;";
say " ignore the_folds; visitor.generic_empty_ctor state;;";
} elsif ($c<isBuiltin>) {
say " ignore the_folds; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
} else {
@ -234,7 +235,7 @@ $*OUT = open $folder_filename, :w;
}
# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
{ say " let fold__$builtin : type qstate . the_folds -> qstate fold_config -> qstate -> $builtin -> qstate = fun the_folds visitor state x ->";
{ say " let fold__$builtin : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun the_folds visitor state x ->";
say " ignore the_folds; visitor.$builtin visitor state x;;"; } # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
say "";
@ -248,15 +249,15 @@ $*OUT = open $folder_filename, :w;
# Tying the knot
say "";
for $adts.list -> $t
{ say " let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> the_folds visitor state x;;";
{ say " let fold__$t<name> : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $t<name> -> out_qstate = fun visitor state x -> fold__$t<name> the_folds visitor state x;;";
for $t<ctorsOrFields>.list -> $c
{ say " let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> the_folds visitor state x;;" } }
{ say " let fold__$t<name>__$c<name> : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> { $c<type> || 'unit' } -> out_qstate = fun visitor state x -> fold__$t<name>__$c<name> the_folds visitor state x;;" } }
# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
{ say " let fold__$builtin : type qstate . qstate fold_config -> qstate -> $builtin -> qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; }
{ say " let fold__$builtin : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; }
say "";
say " module Folds (M : sig type state type 'a t val f : (state fold_config -> state -> 'a -> state) -> 'a t end) = struct";
say " module Folds (M : sig type in_state type out_state type 'a t val f : ((in_state , out_state) fold_config -> in_state -> 'a -> out_state) -> 'a t end) = struct";
for $adts.list -> $t
{ say " let $t<name> = M.f fold__$t<name>;;"; }
# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')

38
src/stages/adt_generator/generic.ml
View File

@ -10,35 +10,35 @@ module BlahBluh = struct
type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
end
module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_config end) = struct
module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct
type kind =
| Record
| Variant
| Poly of string
type 'state record_instance = {
fields : 'state ctor_or_field_instance list;
type ('in_state , 'out_state) record_instance = {
fields : ('in_state , 'out_state) ctor_or_field_instance list;
}
and 'state constructor_instance = {
constructor : 'state ctor_or_field_instance ;
and ('in_state , 'out_state) constructor_instance = {
constructor : ('in_state , 'out_state) ctor_or_field_instance ;
variant : ctor_or_field list
}
and 'state poly_instance = {
and ('in_state , 'out_state) poly_instance = {
poly : string;
arguments : string list;
poly_continue : 'state -> 'state
poly_continue : 'in_state -> 'out_state
}
and 'state kind_instance =
| RecordInstance of 'state record_instance
| VariantInstance of 'state constructor_instance
| PolyInstance of 'state poly_instance
and ('in_state , 'out_state) kind_instance =
| RecordInstance of ('in_state , 'out_state) record_instance
| VariantInstance of ('in_state , 'out_state) constructor_instance
| PolyInstance of ('in_state , 'out_state) poly_instance
and 'state instance = {
and ('in_state , 'out_state) instance = {
instance_declaration_name : string;
instance_kind : 'state kind_instance;
instance_kind : ('in_state , 'out_state) kind_instance;
}
and ctor_or_field =
@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
type_ : string;
}
and 'state ctor_or_field_instance =
and ('in_state , 'out_state) ctor_or_field_instance =
{
cf : ctor_or_field;
cf_continue : 'state -> 'state;
cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> 'state;
cf_continue : 'in_state -> 'out_state;
cf_new_fold : 'in_state 'out_state . ('in_state , 'out_state , (('in_state , 'out_state) node_instance_info)) M.fold_config -> 'in_state -> 'out_state;
}
and node =
@ -64,9 +64,9 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
(* TODO: rename things a bit in this file. *)
and adt = node list
and 'state node_instance_info = {
and ('in_state , 'out_state) node_instance_info = {
adt : adt ;
node_instance : 'state instance ;
node_instance : ('in_state , 'out_state) instance ;
}
and 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
and ('in_state , 'out_state) ctor_or_field_instance_info = adt * node * ('in_state , 'out_state) ctor_or_field_instance
end

28
src/test/adt_generator/use_a_fold.ml
View File

@ -63,35 +63,33 @@ let () =
let _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
let _nob : (bool, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
type no_state = NoState
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 state info ->
assert_nostate state;
let op : ('i, 'o) Generated_fold.fold_config = {
generic = (fun NoState info ->
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) ^ " }"
false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }"
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } ->
(match cf_continue nostate with
(match cf_continue NoState with
| true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate)
(poly_continue NoState)
) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
unit = (fun _visitor state () -> assert_nostate state; false , "()") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
list = (fun _visitor continue state lst ->
assert_nostate state;
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
generic_empty_ctor = (fun NoState -> false, "") ;
string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ;
unit = (fun _visitor NoState () -> false , "()") ;
int = (fun _visitor NoState i -> false , string_of_int i) ;
list = (fun _visitor continue NoState lst ->
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 nostate some_root in
let (_ , state) = Generated_fold.fold__root op NoState some_root 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
()