From 9e21123de0df20d6ee6a9830a28d77bb04c452b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 10 Apr 2020 03:13:22 +0200 Subject: [PATCH] Generic PP: use PPF, split test for parentheses to separate fold --- src/stages/4-ast_typed/PP_generic.ml | 125 ++++++++++++++++-------- src/stages/4-ast_typed/types.ml | 1 + src/stages/4-ast_typed/types_utils.ml | 9 +- src/stages/adt_generator/generator.raku | 26 +++-- src/stages/adt_generator/generic.ml | 13 +-- src/test/adt_generator/use_a_fold.ml | 2 +- 6 files changed, 119 insertions(+), 57 deletions(-) diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml index 22ad1a2a1..47f4f2551 100644 --- a/src/stages/4-ast_typed/PP_generic.ml +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -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 diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 28ffb6644..c2d06fa15 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -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 diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 24835256c..ffb1b683d 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -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) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index f3938f900..6fc05e73b 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -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({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).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({$_ ne $record && $_ ne $variant}).map({$_}).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__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; say " cf = info__$t__$c;"; - say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor state x;"; + say " cf_continue = (fun state -> blahblah.fold__$t__$c blahblah visitor state x);"; + say " cf_new_fold = (fun visitor state -> blahblah.fold__$t__$c blahblah visitor state x);"; say '};;'; say ""; } say "(* info for node $t *)"; @@ -461,8 +467,8 @@ say '};;'; say ""; for $adts.list -> $t -{ say "let with__$t : _ = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; - say "let with__$t__pre_state : _ = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; - say "let with__$t__post_state : _ = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; +{ say "let with__$t : _ -> _ fold_map_config -> _ fold_map_config = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; + say "let with__$t__pre_state : _ -> _ fold_map_config -> _ fold_map_config = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; + say "let with__$t__post_state : _ -> _ fold_map_config -> _ fold_map_config = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; for $t.list -> $c - { say "let with__$t__$c : _ = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } + { say "let with__$t__$c : _ -> _ fold_map_config -> _ fold_map_config = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml index 7defcfbb2..c4f28821a 100644 --- a/src/stages/adt_generator/generic.ml +++ b/src/stages/adt_generator/generic.ml @@ -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 diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index f49e42c7d..8cfd5aa3a 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -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)