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 open PP_helpers
module M = struct module M = struct
type no_state = NoState
let needs_parens = { let needs_parens = {
generic = (fun state info -> generic = (fun NoState info ->
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance _ -> false | RecordInstance _ -> false
| VariantInstance _ -> true | VariantInstance _ -> true
| PolyInstance { poly =_; arguments=_; poly_continue } -> | PolyInstance { poly =_; arguments=_; poly_continue } ->
(poly_continue state) (poly_continue NoState)
); );
generic_empty_ctor = (fun _ -> false) ;
type_variable = (fun _ _ _ -> true) ; type_variable = (fun _ _ _ -> true) ;
bool = (fun _ _ _ -> false) ; bool = (fun _ _ _ -> false) ;
int = (fun _ _ _ -> false) ; int = (fun _ _ _ -> false) ;
@ -37,83 +39,81 @@ module M = struct
typeVariableMap = (fun _ _ _ _ -> false) ; typeVariableMap = (fun _ _ _ _ -> false) ;
} }
let op ppf = { let op ppf : (no_state, unit) fold_config = {
generic = (fun () info -> generic = (fun NoState info ->
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | RecordInstance { fields } ->
let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) = let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in 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 fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
| VariantInstance { constructor ; _ } -> | VariantInstance { constructor ; _ } ->
if constructor.cf_new_fold needs_parens false if constructor.cf_new_fold needs_parens NoState
then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () 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 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 } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue ()) (poly_continue NoState)
); );
int = (fun _visitor () i -> fprintf ppf "%i" i ); generic_empty_ctor = (fun NoState -> ()) ;
type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; int = (fun _visitor NoState i -> fprintf ppf "%i" i );
bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ; type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ; bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ;
string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ; z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ;
ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ; string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ;
bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ; ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ;
unit = (fun _visitor () () -> fprintf ppf "()") ; bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ;
packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ; unit = (fun _visitor NoState () -> fprintf ppf "()") ;
expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ; packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ;
constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ; expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ;
location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ; constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ; location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ;
ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ;
constructor_map = (fun _visitor continue () cmap -> 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 lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
let aux ppf (Constructor k, v) = 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); 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 lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
let aux ppf (Label k, v) = 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); 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 = 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); 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 let ({ wrap_content; location } : _ Location.wrap) = lwrap in
fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location); fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location);
(* list_ne = (fun _visitor continue () (first, lst) -> option = (fun _visitor continue NoState o ->
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 ->
match o with match o with
| None -> fprintf ppf "None" | None -> fprintf ppf "None"
| Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ; | Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ;
poly_unionfind = (fun _visitor continue () p -> poly_unionfind = (fun _visitor continue NoState p ->
let lst = (UnionFind.Poly2.partitions p) in let lst = (UnionFind.Poly2.partitions p) in
let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]" let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]"
(fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p) (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p)
(list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in
let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
fprintf ppf "UnionFind [@,@[<hv 2> %a @]@,]" aux2 lst); 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 let lst = (RedBlackTrees.PolySet.elements set) in
fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst); fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst);
typeVariableMap = (fun _visitor continue () tvmap -> typeVariableMap = (fun _visitor continue NoState tvmap ->
let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
let aux ppf (k, v) = 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); 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 -> let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
fold (op ppf) () v fold (op ppf) NoState v
end end
include Fold.Folds(struct include Fold.Folds(struct
type state = unit ;; type in_state = M.no_state ;;
type out_state = unit ;;
type 'a t = formatter -> 'a -> unit ;; type 'a t = formatter -> 'a -> unit ;;
let f = M.print ;; let f = M.print ;;
end) 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. *) let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *)
type 'a lz = unit -> 'a (* Lazy values *) type 'a lz = unit -> 'a (* Lazy values *)
type t = type t =
| NoState | EmptyCtor
| Record of string * (string * t lz) list | Record of string * (string * t lz) list
| VariantConstructor of string * string * t lz | VariantConstructor of string * string * t lz
| Bool of inline | Bool of inline
@ -30,12 +30,14 @@ module M = struct
| Set of t lz list | Set of t lz list
| TypeVariableMap of (type_variable * t lz) list | TypeVariableMap of (type_variable * t lz) list
type no_state = NoState
(* TODO: make these functions return a lazy stucture *) (* TODO: make these functions return a lazy stucture *)
let op : t fold_config = { let op : (no_state, t) fold_config = {
generic = (fun _state info -> generic = (fun NoState info ->
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | 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 ( fld.cf.name , fun () -> fld.cf_continue NoState ) in
Record ("name_of_the_record", List.map aux fields) Record ("name_of_the_record", List.map aux fields)
| VariantInstance { constructor ; _ } -> | VariantInstance { constructor ; _ } ->
@ -43,6 +45,7 @@ module M = struct
| PolyInstance { poly=_; arguments=_; poly_continue } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
poly_continue NoState poly_continue NoState
); );
generic_empty_ctor = (fun NoState -> EmptyCtor) ;
int = (fun _visitor _state i -> Int i ); int = (fun _visitor _state i -> Int i );
type_variable = (fun _visitor _state type_variable -> Var type_variable) ; type_variable = (fun _visitor _state type_variable -> Var type_variable) ;
bool = (fun _visitor _state b -> Bool b) ; bool = (fun _visitor _state b -> Bool b) ;
@ -72,7 +75,7 @@ module M = struct
(Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location})); (Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location}));
option = (fun _visitor continue _state o -> option = (fun _visitor continue _state o ->
match o with 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)); | Some v -> VariantConstructor ("built-in:option", "Some", fun () -> continue NoState v));
poly_unionfind = (fun _visitor continue _state p -> poly_unionfind = (fun _visitor continue _state p ->
(* UnionFind.Poly2.partitions returns the partitions in a (* 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)); 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 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 (* Generate a unique tag for each case handled below. We can then
compare data by their tag and contents. *) compare data by their tag and contents. *)
let tag = function let tag = function
| NoState -> 0 | EmptyCtor -> 0
| Record _ -> 1 | Record _ -> 1
| VariantConstructor _ -> 2 | VariantConstructor _ -> 2
| Bool _ -> 3 | Bool _ -> 3
@ -129,7 +136,7 @@ module M = struct
and compare_lz_t a b = compare_t (a ()) (b ()) and compare_lz_t a b = compare_t (a ()) (b ())
and compare_t (a : t) (b : t) = and compare_t (a : t) (b : t) =
match (a, b) with 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 | (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)) -> | (VariantConstructor (va, ca, xa), VariantConstructor (vb, cb, xb)) ->
cmp3 cmp3
@ -158,21 +165,22 @@ module M = struct
| (Set a, Set b) -> List.compare ~compare:compare_lz_t a b | (Set a, Set b) -> List.compare ~compare:compare_lz_t a b
| (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry 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), | ((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),
((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 b) ->
Int.compare (tag a) (tag 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) 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 } { compare = mk_compare fold }
end end
(* Generate a comparison function for each type, named like the type itself. *) (* Generate a comparison function for each type, named like the type itself. *)
include Folds(struct include Folds(struct
type state = M.t ;; type in_state = M.no_state ;;
type out_state = M.t ;;
type 'a t = 'a -> 'a -> int ;; type 'a t = 'a -> 'a -> int ;;
let f = M.mk_compare ;; let f = M.mk_compare ;;
end) end)
@ -180,7 +188,8 @@ end)
module Comparable = struct module Comparable = struct
(* Generate a comparator typeclass-like object for each type, named like the type itself. *) (* Generate a comparator typeclass-like object for each type, named like the type itself. *)
include Folds(struct 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 ;; type 'a t = 'a extra_info__comparable ;;
let f = M.mk_comparable ;; let f = M.mk_comparable ;;
end) end)

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

@ -96,29 +96,30 @@ $*OUT = open $folder_filename, :w;
say ""; say "";
say " include Adt_generator.Generic.BlahBluh"; say " include Adt_generator.Generic.BlahBluh";
say " type ('state , 'adt_info_node_instance_info) _fold_config = \{"; say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
say " generic : 'state -> 'adt_info_node_instance_info -> 'state;"; 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 '') # 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 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 # look for built-in polymorphic types
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly 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 ""; say "";
say " module Adt_info = Adt_generator.Generic.Adt_info (struct"; 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 " end);;";
say " include Adt_info;;"; 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 "";
say ' type the_folds = {'; say ' type the_folds = {';
for $adts.list -> $t 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 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 ' };;'; say ' };;';
# generic programming info about the nodes and fields # generic programming info about the nodes and fields
@ -132,7 +133,7 @@ $*OUT = open $folder_filename, :w;
say " type_ = \"$c<type>\";"; say " type_ = \"$c<type>\";";
say ' };;'; say ' };;';
# 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 = info__$t<name>__$c<name>;";
say " cf_continue = (fun state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);"; 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);"; 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 ' };;';
# say ""; # say "";
# TODO: factor out some of the common bits here. # 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 ' {';
say " instance_declaration_name = \"$t<name>\";"; say " instance_declaration_name = \"$t<name>\";";
do given $t<kind> { do given $t<kind> {
@ -208,9 +209,9 @@ $*OUT = open $folder_filename, :w;
# fold functions # fold functions
say ""; say "";
for $adts.list -> $t 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. # 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 " adt = whole_adt_info () ;";
say " node_instance = continue_info__$t<name> the_folds visitor x"; say " node_instance = continue_info__$t<name> the_folds visitor x";
say ' } in'; say ' } in';
@ -218,11 +219,11 @@ $*OUT = open $folder_filename, :w;
say " visitor.generic state node_instance_info;;"; say " visitor.generic state node_instance_info;;";
# say ""; # say "";
for $t<ctorsOrFields>.list -> $c 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 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 : 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 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 '') { if ($c<type> eq '') {
# nothing to do, this constructor has no arguments. # 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>) { } elsif ($c<isBuiltin>) {
say " ignore the_folds; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) say " ignore the_folds; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
} else { } 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 '') # 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 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 " ignore the_folds; visitor.$builtin visitor state x;;"; } # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
say ""; say "";
@ -248,15 +249,15 @@ $*OUT = open $folder_filename, :w;
# Tying the knot # Tying the knot
say ""; say "";
for $adts.list -> $t 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 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 '') # 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 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 "";
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 for $adts.list -> $t
{ say " let $t<name> = M.f fold__$t<name>;;"; } { 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 '') # 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;; type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
end 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 = type kind =
| Record | Record
| Variant | Variant
| Poly of string | Poly of string
type 'state record_instance = { type ('in_state , 'out_state) record_instance = {
fields : 'state ctor_or_field_instance list; fields : ('in_state , 'out_state) ctor_or_field_instance list;
} }
and 'state constructor_instance = { and ('in_state , 'out_state) constructor_instance = {
constructor : 'state ctor_or_field_instance ; constructor : ('in_state , 'out_state) ctor_or_field_instance ;
variant : ctor_or_field list variant : ctor_or_field list
} }
and 'state poly_instance = { and ('in_state , 'out_state) poly_instance = {
poly : string; poly : string;
arguments : string list; arguments : string list;
poly_continue : 'state -> 'state poly_continue : 'in_state -> 'out_state
} }
and 'state kind_instance = and ('in_state , 'out_state) kind_instance =
| RecordInstance of 'state record_instance | RecordInstance of ('in_state , 'out_state) record_instance
| VariantInstance of 'state constructor_instance | VariantInstance of ('in_state , 'out_state) constructor_instance
| PolyInstance of 'state poly_instance | PolyInstance of ('in_state , 'out_state) poly_instance
and 'state instance = { and ('in_state , 'out_state) instance = {
instance_declaration_name : string; instance_declaration_name : string;
instance_kind : 'state kind_instance; instance_kind : ('in_state , 'out_state) kind_instance;
} }
and ctor_or_field = and ctor_or_field =
@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
type_ : string; type_ : string;
} }
and 'state ctor_or_field_instance = and ('in_state , 'out_state) ctor_or_field_instance =
{ {
cf : ctor_or_field; cf : ctor_or_field;
cf_continue : 'state -> 'state; cf_continue : 'in_state -> 'out_state;
cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> '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 = 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. *) (* TODO: rename things a bit in this file. *)
and adt = node list and adt = node list
and 'state node_instance_info = { and ('in_state , 'out_state) node_instance_info = {
adt : adt ; 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 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 _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
let _nob : (bool, [> 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 () =
let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; 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 assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in let op : ('i, 'o) Generated_fold.fold_config = {
let nostate = false, "" in generic = (fun NoState info ->
let op = {
generic = (fun state info ->
assert_nostate state;
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | 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=_ } -> | 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 ^ ")" | true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg) | false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate) (poly_continue NoState)
) ; ) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ; generic_empty_ctor = (fun NoState -> false, "") ;
unit = (fun _visitor state () -> assert_nostate state; false , "()") ; string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ; unit = (fun _visitor NoState () -> false , "()") ;
list = (fun _visitor continue state lst -> int = (fun _visitor NoState i -> false , string_of_int i) ;
assert_nostate state; list = (fun _visitor continue NoState lst ->
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ; false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ;
(* generic_ctor_or_field = (fun _info state -> (* generic_ctor_or_field = (fun _info state ->
* match _info () with * match _info () with
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
* ); *) * ); *)
} in } 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 let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
if String.equal state expected; then if String.equal state expected; then
() ()