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

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 ->
+let needs_parens              = {
-  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 _ -> 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 } ->
-           false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
+         let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) =
-        | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue }; variant=_ } ->
+           fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in
-           (match cf_continue nostate with
+         fprintf ppf "{ %a }" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) fields
-            | true,  arg -> true, name ^ " (" ^ arg ^ ")"
+      | VariantInstance { constructor ; _ } ->
-            | false, arg -> true, name ^ " "  ^ arg)
+         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 nostate)
+         (poly_continue ())
     );
-      type_variable =  (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
+    type_variable             = (fun _visitor () type_variable   -> fprintf ppf "%a" Var.pp type_variable) ;
-      type_meta = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
+    bool                      = (fun _visitor () b               -> fprintf ppf "%s" (if b then "true" else "false")) ;
-      bool = (fun _visitor state b -> assert_nostate state; false , if b then "true" else "false") ;
+    int                       = (fun _visitor () i               -> fprintf ppf "%d" i) ;
-      int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
+    string                    = (fun _visitor () str             -> fprintf ppf "\"%s\"" str) ;
-      string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
+    bytes                     = (fun _visitor () _bytes          -> fprintf ppf "bytes...") ;
-      bytes = (fun _visitor state bytes -> assert_nostate state; false , (ignore bytes;"TODO:BYTES")) ;
+    packed_internal_operation = (fun _visitor () _op             -> fprintf ppf "Operation(...bytes)") ;
-      packed_internal_operation =  (fun _visitor state op -> assert_nostate state; false , (ignore op;"TODO:PACKED_INTERNAL_OPERATION")) ;
+    expression_variable       = (fun _visitor () ev              -> fprintf ppf "%a" Var.pp ev) ;
-      expression_variable =  (fun _visitor state ev -> assert_nostate state; false , (ignore ev;"TODO:EXPRESSION_VARIABLE")) ;
+    constructor'              = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ;
-      constructor' =  (fun _visitor state c -> assert_nostate state; false , (ignore c;"TODO:CONSTRUCTOR'")) ;
+    location                  = (fun _visitor () loc             -> fprintf ppf "%a" Location.pp loc) ;
-      location =  (fun _visitor state loc -> assert_nostate state; false , (ignore loc;"TODO:LOCATION'")) ;
+    label                     = (fun _visitor () (Label lbl)     -> fprintf ppf "Label %s" lbl) ;
-      label = (fun _visitor state (Label lbl) -> assert_nostate state; true, "Label " ^ lbl) ;
+    ast_core_type_expression  = (fun _visitor () te              -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
-      constructor_map =  (fun _visitor continue state cmap -> assert_nostate state; false , (ignore (continue,cmap);"TODO:constructor_map")) ;
+    constructor_map           = (fun _visitor continue () cmap   ->
-      label_map =  (fun _visitor continue state lmap -> assert_nostate state; false , (ignore (continue,lmap);"TODO:label_map")) ;
+      let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
-      list = (fun _visitor continue state lst ->
+      let aux ppf (Constructor k, v) =
-        assert_nostate state;
+        fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
-        false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
+      fprintf ppf "CMap [ %a ]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
-      location_wrap =  (fun _visitor continue state lwrap -> assert_nostate state; false , (ignore (continue,lwrap);"TODO:location_wrap")) ;
+    label_map                 = (fun _visitor continue () lmap   ->
-      list_ne =  (fun _visitor continue state list_ne -> assert_nostate state; false , (ignore (continue,list_ne);"TODO:location_wrap")) ;
+      let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
-    } in
+      let aux ppf (Label k, v) =
-  let (_ , state) = fold__program op nostate p in
+        fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
-  Printf.printf "%s" state
+      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

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

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)

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({ $_<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> : _ -> _ 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 : _ = (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>__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 : _ = (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>__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> \} \});;"; } }

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
+  and adt = node list
-  type 'state node_instance_info = {
+  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

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)