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

Generic PP: use PPF, split test for parentheses to separate fold

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-04-10 03:13:22 +02:00
parent 22fce03844
commit 9e21123de0
6 changed files with 119 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,42 +1,89 @@
open Types
open Fold
open Format
open PP_helpers
let print_program : formatter -> program -> unit = fun ppf p ->
ignore ppf ;
let assert_nostate _ = () in (* (needs_parens, state) = assert (not needs_parens && match state with None -> true | Some _ -> false) in *)
let nostate = false, "" in
let op = {
generic = (fun state info ->
assert_nostate state;
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue }; variant=_ } ->
(match cf_continue nostate with
| true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate)
);
type_variable = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
type_meta = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
bool = (fun _visitor state b -> assert_nostate state; false , if b then "true" else "false") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
bytes = (fun _visitor state bytes -> assert_nostate state; false , (ignore bytes;"TODO:BYTES")) ;
packed_internal_operation = (fun _visitor state op -> assert_nostate state; false , (ignore op;"TODO:PACKED_INTERNAL_OPERATION")) ;
expression_variable = (fun _visitor state ev -> assert_nostate state; false , (ignore ev;"TODO:EXPRESSION_VARIABLE")) ;
constructor' = (fun _visitor state c -> assert_nostate state; false , (ignore c;"TODO:CONSTRUCTOR'")) ;
location = (fun _visitor state loc -> assert_nostate state; false , (ignore loc;"TODO:LOCATION'")) ;
label = (fun _visitor state (Label lbl) -> assert_nostate state; true, "Label " ^ lbl) ;
constructor_map = (fun _visitor continue state cmap -> assert_nostate state; false , (ignore (continue,cmap);"TODO:constructor_map")) ;
label_map = (fun _visitor continue state lmap -> assert_nostate state; false , (ignore (continue,lmap);"TODO:label_map")) ;
list = (fun _visitor continue state lst ->
assert_nostate state;
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
location_wrap = (fun _visitor continue state lwrap -> assert_nostate state; false , (ignore (continue,lwrap);"TODO:location_wrap")) ;
list_ne = (fun _visitor continue state list_ne -> assert_nostate state; false , (ignore (continue,list_ne);"TODO:location_wrap")) ;
} in
let (_ , state) = fold__program op nostate p in
Printf.printf "%s" state
let needs_parens = {
generic = (fun state info ->
match info.node_instance.instance_kind with
| RecordInstance _ -> false
| VariantInstance _ -> true
| PolyInstance { poly =_; arguments=_; poly_continue } ->
(poly_continue state)
);
type_variable = (fun _ _ _ -> false) ;
bool = (fun _ _ _ -> false) ;
int = (fun _ _ _ -> false) ;
string = (fun _ _ _ -> false) ;
bytes = (fun _ _ _ -> false) ;
packed_internal_operation = (fun _ _ _ -> false) ;
expression_variable = (fun _ _ _ -> false) ;
constructor' = (fun _ _ _ -> false) ;
location = (fun _ _ _ -> false) ;
label = (fun _ _ _ -> false) ;
ast_core_type_expression = (fun _ _ _ -> true) ;
constructor_map = (fun _ _ _ _ -> false) ;
label_map = (fun _ _ _ _ -> false) ;
list = (fun _ _ _ _ -> false) ;
location_wrap = (fun _ _ _ _ -> false) ;
list_ne = (fun _ _ _ _ -> false) ;
option = (fun _visitor _continue _state o ->
match o with None -> false | Some _ -> true) ;
}
let op ppf = {
generic = (fun () 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
fprintf ppf "{ %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) ()
else fprintf ppf "%s %a" constructor.cf.name (fun _ppf -> constructor.cf_continue) ()
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue ())
);
type_variable = (fun _visitor () type_variable -> fprintf ppf "%a" Var.pp type_variable) ;
bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ;
int = (fun _visitor () i -> fprintf ppf "%d" i) ;
string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ;
bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ;
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 ->
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 "CMap [ %a ]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
label_map = (fun _visitor continue () 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 "LMap [ %a ]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
list = (fun _visitor continue () lst ->
let aux ppf elt =
fprintf ppf "%a" (fun _ppf -> continue ()) elt in
fprintf ppf "[ %a ]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
location_wrap = (fun _visitor continue () 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 "[ %a ]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) (first::lst));
option = (fun _visitor continue () o ->
match o with
| None -> fprintf ppf "None"
| Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ;
}
let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
fold (op ppf) () v
let program = print fold__program
let type_expression = print fold__type_expression

1
src/stages/4-ast_typed/types.ml
View File

@ -21,6 +21,7 @@ type type_constant =
type te_cmap = type_expression constructor_map
and te_lmap = type_expression label_map
and type_meta = ast_core_type_expression option
and type_content =
| T_sum of te_cmap

9
src/stages/4-ast_typed/types_utils.ml
View File

@ -21,7 +21,8 @@ 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 ast_core_type_expression = S.type_expression
type 'a location_wrap = 'a Location.wrap
type 'a list_ne = 'a List.Ne.t
@ -69,3 +70,9 @@ let fold_map__list_ne : type a state new_a . (state -> a -> (state * new_a) resu
ok (state , new_element :: l) in
let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
ok (state , (new_first , l))
let fold_map__option : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a option -> (state * new_a option) Simple_utils.Trace.result =
fun f state o ->
match o with
| None -> ok (state, None)
| Some v -> let%bind state, v = f state v in ok (state, Some v)

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

@ -147,7 +147,6 @@ say "type 'a monad = 'a Simple_utils.Trace.result;;";
say "let (>>?) v f = Simple_utils.Trace.bind f v;;";
say "let return v = Simple_utils.Trace.ok v;;";
say "open $moduleName;;";
say "module Adt_info = Adt_generator.Generic.Adt_info;;";
say "";
say "(* must be provided by one of the open or include statements: *)";
@ -224,16 +223,22 @@ say '};;';
say "(* map from node names to their generic folds *)";
say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;";
say "";
say "type 'state fold_config =";
say "type ('state , 'adt_info_node_instance_info) _fold_config =";
say ' {';
say " generic : 'state -> 'state Adt_info.node_instance_info -> 'state;";
say " generic : 'state -> 'adt_info_node_instance_info -> '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 fold_config -> 'state -> $builtin -> 'state;"; }
{ say " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; }
# look for built-in polymorphic types
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say " $poly : 'a . 'state fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
{ say " $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
say ' };;';
say "module Arg = struct";
say " type nonrec ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;";
say "end;;";
say "module Adt_info = Adt_generator.Generic.Adt_info (Arg);;";
say "include Adt_info;;";
say "type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;";
say "";
say 'type blahblah = {';
@ -256,7 +261,8 @@ for $adts.list -> $t
say "";
say "let continue_info__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
say " cf = info__$t<name>__$c<name>;";
say " cf_continue = fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x;";
say " cf_continue = (fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x);";
say " cf_new_fold = (fun visitor state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x);";
say '};;';
say ""; }
say "(* info for node $t<name> *)";
@ -461,8 +467,8 @@ say '};;';
say "";
for $adts.list -> $t
{ say "let with__$t<name> : _ = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
say "let with__$t<name>__pre_state : _ = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
say "let with__$t<name>__post_state : _ = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
{ say "let with__$t<name> : _ -> _ fold_map_config -> _ fold_map_config = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
say "let with__$t<name>__pre_state : _ -> _ fold_map_config -> _ fold_map_config = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
say "let with__$t<name>__post_state : _ -> _ fold_map_config -> _ fold_map_config = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
for $t<ctorsOrFields>.list -> $c
{ say "let with__$t<name>__$c<name> : _ = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }
{ say "let with__$t<name>__$c<name> : _ -> _ fold_map_config -> _ fold_map_config = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }

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

@ -1,4 +1,4 @@
module Adt_info = struct
module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_config end) = struct
type kind =
| Record
| Variant
@ -39,10 +39,11 @@ module Adt_info = struct
and 'state ctor_or_field_instance =
{
cf : ctor_or_field;
cf_continue : 'state -> 'state
cf_continue : 'state -> 'state;
cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> 'state;
}
type node =
and node =
{
kind : kind;
declaration_name : string;
@ -50,10 +51,10 @@ module Adt_info = struct
}
(* TODO: rename things a bit in this file. *)
type adt = node list
type 'state node_instance_info = {
and adt = node list
and 'state node_instance_info = {
adt : adt ;
node_instance : 'state instance ;
}
type 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
and 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
end

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

@ -71,7 +71,7 @@ let () =
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue }; variant=_ } ->
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } ->
(match cf_continue nostate with
| true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg)